{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnicodeSyntax #-}

module MatrixBot.AesonUtils where

import GHC.Generics

import Data.Aeson
import Data.Aeson.Types (Parser)
import Data.Char
import Data.Function
import Data.Typeable

import Control.Category ((>>>))


myGenericToJSON ∷ ∀a. (Generic a, Typeable a, GToJSON' Value Zero (Rep a)) ⇒ a → Value
myGenericToJSON :: forall a.
(Generic a, Typeable a, GToJSON' Value Zero (Rep a)) =>
a -> Value
myGenericToJSON
  = Options -> a -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
genericToJSON
  (Options -> a -> Value) -> Options -> a -> Value
forall a b. (a -> b) -> a -> b
$ Options
defaultOptions
  Options -> (Options -> Options) -> Options
forall a b. a -> (a -> b) -> b
& forall a. Typeable a => Proxy a -> Options -> Options
cutTypeNamePrefix @a Proxy a
forall {k} (t :: k). Proxy t
Proxy
  Options -> (Options -> Options) -> Options
forall a b. a -> (a -> b) -> b
& Options -> Options
camelCaseToSnakeCase


myGenericParseJSON ∷ ∀a. (Generic a, Typeable a, GFromJSON Zero (Rep a)) ⇒ Value → Parser a
myGenericParseJSON :: forall a.
(Generic a, Typeable a, GFromJSON Zero (Rep a)) =>
Value -> Parser a
myGenericParseJSON
  = Options -> Value -> Parser a
forall a.
(Generic a, GFromJSON Zero (Rep a)) =>
Options -> Value -> Parser a
genericParseJSON
  (Options -> Value -> Parser a) -> Options -> Value -> Parser a
forall a b. (a -> b) -> a -> b
$ Options
defaultOptions
  Options -> (Options -> Options) -> Options
forall a b. a -> (a -> b) -> b
& forall a. Typeable a => Proxy a -> Options -> Options
cutTypeNamePrefix @a Proxy a
forall {k} (t :: k). Proxy t
Proxy
  Options -> (Options -> Options) -> Options
forall a b. a -> (a -> b) -> b
& Options -> Options
camelCaseToSnakeCase


-- | Cut type name prefix from each field
--
-- For instance if type is called “Foo” and its fields are “fooBar” and “fooBaz” then its fields
-- will be named “bar” and “baz”. If prefix doesn’t equal to “foo” (to the type name) then the field
-- name stays unchanged.
cutTypeNamePrefix ∷ ∀a. Typeable a ⇒ Proxy a → Options → Options
cutTypeNamePrefix :: forall a. Typeable a => Proxy a -> Options -> Options
cutTypeNamePrefix Proxy a
Proxy Options
opts = Options
opts
  { fieldLabelModifier = fieldLabelModifier opts >>> \String
x →
      let
        typeNamePrefix :: String
typeNamePrefix
          = String -> String
cutTypeParams
          (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ case TypeRep -> String
forall a. Show a => a -> String
show (TypeRep -> String) -> (Proxy a -> TypeRep) -> Proxy a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a -> String) -> Proxy a -> String
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a of
              Char
a : String
as → Char -> Char
toLower Char
a Char -> String -> String
forall a. a -> [a] -> [a]
: String
as
              String
a → String
a

        cutTypeParams :: String -> String
cutTypeParams String
"" = String
""
        cutTypeParams (Char
' ' : String
_) = String
""
        cutTypeParams (Char
c : String
cs) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
cutTypeParams String
cs
      in
        case Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
typeNamePrefix) String
x of
          (String
a, Char
b : String
bs) | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
typeNamePrefix → Char -> Char
toLower Char
b Char -> String -> String
forall a. a -> [a] -> [a]
: String
bs
          (String, String)
_ → String
x
  }


-- | Convert “camelCase” to “snake_case” for each field
camelCaseToSnakeCase ∷ Options → Options
camelCaseToSnakeCase :: Options -> Options
camelCaseToSnakeCase Options
opts = Options
opts
  { fieldLabelModifier = (fieldLabelModifier opts >>>) $ foldMap $ \case
      Char
c | Char -> Bool
isUpper Char
c → [Char
'_', Char -> Char
toLower Char
c]
        | Bool
otherwise → Char -> String
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
  }