-- |
-- TH utils for aeson.
module DomainAeson.Util.AesonTH where

import qualified Data.Aeson as Ae
import qualified Data.Aeson.Key as AeKey
import qualified Data.Aeson.KeyMap as AeKeyMap
import qualified Data.Text as Text
import qualified Data.Vector as Vector
import DomainAeson.Prelude
import Language.Haskell.TH.Syntax
import THLego.Helpers
import qualified THLego.Lambdas as Lambdas
import qualified TemplateHaskell.Compat.V0208 as Compat

productParseJsonD :: Name -> [(Text, Bool)] -> Dec
productParseJsonD :: Name -> [(Text, Bool)] -> Dec
productParseJsonD Name
conName [(Text, Bool)]
fields =
  Name -> [Clause] -> Dec
FunD 'Ae.parseJSON [Clause
clause]
  where
    clause :: Clause
clause =
      [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
exp) []
      where
        exp :: Exp
exp =
          Exp -> [Exp] -> Exp
multiAppE
            (Name -> Exp
VarE 'Ae.withObject)
            [ Lit -> Exp
LitE (String -> Lit
StringL (Name -> String
nameString Name
conName)),
              Name -> [(Text, Bool)] -> Exp
productObjectParsingLamE Name
conName [(Text, Bool)]
fields
            ]

productObjectParsingLamE :: Name -> [(Text, Bool)] -> Exp
productObjectParsingLamE :: Name -> [(Text, Bool)] -> Exp
productObjectParsingLamE Name
conName [(Text, Bool)]
fields =
  [Pat] -> Exp -> Exp
LamE [Name -> Pat
VarP Name
aName] (Exp -> Name -> [(Text, Bool)] -> Exp
productObjectParserE (Name -> Exp
ConE Name
aName) Name
conName [(Text, Bool)]
fields)

productObjectParserE :: Exp -> Name -> [(Text, Bool)] -> Exp
productObjectParserE :: Exp -> Name -> [(Text, Bool)] -> Exp
productObjectParserE Exp
objectE Name
conName [(Text, Bool)]
fields =
  Exp -> [Exp] -> Exp
applicativeChainE (Name -> Exp
ConE Name
conName) (((Text, Bool) -> Exp) -> [(Text, Bool)] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Bool) -> Exp
fieldE [(Text, Bool)]
fields)
  where
    fieldE :: (Text, Bool) -> Exp
fieldE (Text
label, Bool
required) =
      Maybe Exp -> Exp -> Maybe Exp -> Exp
InfixE (Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
objectE) (Name -> Exp
VarE Name
opName) (Exp -> Maybe Exp
forall a. a -> Maybe a
Just (Text -> Exp
textLitE Text
label))
      where
        opName :: Name
opName =
          if Bool
required
            then '(Ae..:)
            else '(Ae..:?)

-- *

toJsonInstanceDec :: Type -> Dec -> Dec
toJsonInstanceDec :: Type -> Dec -> Dec
toJsonInstanceDec Type
type_ Dec
toJsonFunDec =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD Maybe Overlap
forall a. Maybe a
Nothing [] Type
headType [Dec
toJsonFunDec]
  where
    headType :: Type
headType =
      Type -> Type -> Type
AppT (Name -> Type
ConT ''Ae.ToJSON) Type
type_

productToJsonInstanceDec :: Type -> Name -> [Text] -> Dec
productToJsonInstanceDec :: Type -> Name -> [Text] -> Dec
productToJsonInstanceDec Type
type_ Name
conName [Text]
members =
  Type -> Dec -> Dec
toJsonInstanceDec Type
type_ (Dec -> Dec) -> Dec -> Dec
forall a b. (a -> b) -> a -> b
$ Name -> [Text] -> Dec
productToJsonFunD Name
conName [Text]
members

sumToJsonInstanceDec :: Type -> [(Text, Name, Int)] -> Dec
sumToJsonInstanceDec :: Type -> [(Text, Name, Int)] -> Dec
sumToJsonInstanceDec Type
type_ [(Text, Name, Int)]
members =
  Type -> Dec -> Dec
toJsonInstanceDec Type
type_ (Dec -> Dec) -> Dec -> Dec
forall a b. (a -> b) -> a -> b
$ [(Text, Name, Int)] -> Dec
sumToJsonFunD [(Text, Name, Int)]
members

enumToJsonInstanceDec :: Type -> [(Text, Name)] -> Dec
enumToJsonInstanceDec :: Type -> [(Text, Name)] -> Dec
enumToJsonInstanceDec Type
type_ [(Text, Name)]
members =
  Type -> Dec -> Dec
toJsonInstanceDec Type
type_ (Dec -> Dec) -> Dec -> Dec
forall a b. (a -> b) -> a -> b
$ [(Text, Name)] -> Dec
enumToJsonFunD [(Text, Name)]
members

-- *

productToJsonFunD :: Name -> [Text] -> Dec
productToJsonFunD :: Name -> [Text] -> Dec
productToJsonFunD Name
conName [Text]
members =
  Name -> [Clause] -> Dec
FunD 'Ae.toJSON [Clause
clause]
  where
    varNamesAndJsonNames :: [(Name, Text)]
varNamesAndJsonNames =
      (Name -> Text -> (Name, Text)) -> [Text] -> [(Name, Text)]
forall a b. (Name -> a -> b) -> [a] -> [b]
mapWithAlphabeticName (,) [Text]
members
    clause :: Clause
clause =
      [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conp Name
conName [Pat]
memberPats] Body
body []
      where
        memberPats :: [Pat]
memberPats = ((Name, Text) -> Pat) -> [(Name, Text)] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, Text) -> Pat
forall b. (Name, b) -> Pat
memberPat [(Name, Text)]
varNamesAndJsonNames
          where
            memberPat :: (Name, b) -> Pat
memberPat (Name
varName, b
_) = Name -> Pat
VarP Name
varName
        body :: Body
body = Exp -> Body
NormalB (Exp -> Body) -> Exp -> Body
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Ae.Object) Exp
mapE
          where
            mapE :: Exp
mapE =
              Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'AeKeyMap.fromList) ([Exp] -> Exp
ListE (((Name, Text) -> Exp) -> [(Name, Text)] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, Text) -> Exp
memberPairE [(Name, Text)]
varNamesAndJsonNames))
            memberPairE :: (Name, Text) -> Exp
memberPairE (Name
varName, Text
jsonName) =
              [Exp] -> Exp
appliedTupleE [Text -> Exp
textKeyE Text
jsonName, Exp -> Exp
toJsonE (Name -> Exp
VarE Name
varName)]

sumToJsonFunD :: [(Text, Name, Int)] -> Dec
sumToJsonFunD :: [(Text, Name, Int)] -> Dec
sumToJsonFunD [(Text, Name, Int)]
members =
  Name -> [Clause] -> Dec
FunD 'Ae.toJSON [Clause]
clauses
  where
    clauses :: [Clause]
clauses = ((Text, Name, Int) -> Clause) -> [(Text, Name, Int)] -> [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Name, Int) -> Clause
memberClause [(Text, Name, Int)]
members
      where
        memberClause :: (Text, Name, Int) -> Clause
memberClause (Text
jsonName, Name
conName, Int
components) =
          case Int
components of
            Int
0 ->
              [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conp Name
conName []] (Exp -> Body
NormalB Exp
bodyExp) []
              where
                bodyExp :: Exp
bodyExp = Text -> Exp
stringJsonE Text
jsonName
            Int
1 ->
              [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conp Name
conName [Name -> Pat
VarP Name
varName]] (Exp -> Body
NormalB Exp
bodyExp) []
              where
                varName :: Name
varName = String -> Name
mkName String
"a"
                bodyExp :: Exp
bodyExp =
                  Exp -> Exp -> Exp
AppE
                    (Name -> Exp
ConE 'Ae.Object)
                    ( Exp -> [Exp] -> Exp
multiAppE
                        (Name -> Exp
VarE 'AeKeyMap.singleton)
                        [ Text -> Exp
textKeyE Text
jsonName,
                          Exp -> Exp
toJsonE (Name -> Exp
VarE Name
varName)
                        ]
                    )
            Int
_ ->
              [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conp Name
conName ((Name -> Pat) -> [Name] -> [Pat]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Pat
VarP [Name]
varNames)] (Exp -> Body
NormalB Exp
bodyExp) []
              where
                varNames :: [Name]
varNames = Int -> [Name]
enumAlphabeticNames Int
components
                bodyExp :: Exp
bodyExp =
                  Exp -> Exp -> Exp
AppE
                    (Name -> Exp
ConE 'Ae.Object)
                    ( Exp -> [Exp] -> Exp
multiAppE
                        (Name -> Exp
VarE 'AeKeyMap.singleton)
                        [ Text -> Exp
textKeyE Text
jsonName,
                          [Exp] -> Exp
jsonArrayE ((Name -> Exp) -> [Name] -> [Exp]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp
toJsonE (Exp -> Exp) -> (Name -> Exp) -> Name -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Name -> Exp
VarE) [Name]
varNames)
                        ]
                    )

enumToJsonFunD :: [(Text, Name)] -> Dec
enumToJsonFunD :: [(Text, Name)] -> Dec
enumToJsonFunD [(Text, Name)]
members =
  Name -> [Clause] -> Dec
FunD 'Ae.toJSON [Clause]
clauses
  where
    clauses :: [Clause]
clauses = ((Text, Name) -> Clause) -> [(Text, Name)] -> [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Name) -> Clause
memberClause [(Text, Name)]
members
      where
        memberClause :: (Text, Name) -> Clause
memberClause (Text
jsonName, Name
conName) =
          [Pat] -> Body -> [Dec] -> Clause
Clause [Name -> [Pat] -> Pat
Compat.conp Name
conName []] (Exp -> Body
NormalB Exp
bodyExp) []
          where
            bodyExp :: Exp
bodyExp = Text -> Exp
stringJsonE Text
jsonName

-- *

jsonArrayE :: [Exp] -> Exp
jsonArrayE :: [Exp] -> Exp
jsonArrayE [Exp]
exps =
  Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Ae.Array) (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Vector.fromList) ([Exp] -> Exp
ListE [Exp]
exps))

stringJsonE :: Text -> Exp
stringJsonE :: Text -> Exp
stringJsonE =
  Exp -> Exp -> Exp
AppE (Name -> Exp
ConE 'Ae.String) (Exp -> Exp) -> (Text -> Exp) -> Text -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fromString) (Exp -> Exp) -> (Text -> Exp) -> Text -> Exp
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Exp
textLitE

textKeyE :: Text -> Exp
textKeyE :: Text -> Exp
textKeyE Text
text =
  Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'AeKey.fromString) (Text -> Exp
textLitE Text
text)

toJsonE :: Exp -> Exp
toJsonE :: Exp -> Exp
toJsonE =
  Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Ae.toJSON)