-- |
-- 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.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

-- * FromJSON

productFromJsonInstanceDec :: Type -> Name -> [(Text, Bool)] -> Dec
productFromJsonInstanceDec :: Type -> Name -> [(Text, Bool)] -> Dec
productFromJsonInstanceDec Type
type_ Name
conName [(Text, Bool)]
fields =
  Type -> Dec -> Dec
fromJsonInstanceDec Type
type_
    forall a b. (a -> b) -> a -> b
$ Name -> [(Text, Bool)] -> Dec
productParseJsonDec Name
conName [(Text, Bool)]
fields

sumFromJsonInstanceDec :: Type -> [(Text, Name, Int)] -> Dec
sumFromJsonInstanceDec :: Type -> [(Text, Name, Int)] -> Dec
sumFromJsonInstanceDec Type
type_ [(Text, Name, Int)]
variants =
  Type -> Dec -> Dec
fromJsonInstanceDec Type
type_
    forall a b. (a -> b) -> a -> b
$ Dec
parseJsonDec
  where
    parseJsonDec :: Dec
parseJsonDec =
      Name -> [Clause] -> Dec
FunD 'Ae.parseJSON [Clause
clause]
      where
        clause :: Clause
clause =
          [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
bodyExp) []
          where
            bodyExp :: Exp
bodyExp =
              [Match] -> Exp
Lambdas.matcher
                [ Pat -> Body -> [Dec] -> Match
Match
                    (Name -> [Pat] -> Pat
Compat.conP 'Ae.Object [Name -> Pat
VarP Name
aName])
                    (Exp -> Body
NormalB (Exp -> [(Text, Name, Int)] -> Exp
sumObjectParserE (Name -> Exp
VarE Name
aName) [(Text, Name, Int)]
variants))
                    [],
                  Pat -> Body -> [Dec] -> Match
Match
                    (Name -> [Pat] -> Pat
Compat.conP 'Ae.String [Name -> Pat
VarP Name
aName])
                    (Exp -> Body
NormalB Exp
stringBody)
                    []
                ]
              where
                stringBody :: Exp
stringBody =
                  Exp -> [Match] -> Exp
CaseE (Name -> Exp
VarE Name
aName) [Match]
matches
                  where
                    matches :: [Match]
matches =
                      forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {l} {a}.
(Item l ~ Char, Eq a, Num a, IsList l) =>
(l, Name, a) -> [Match] -> [Match]
step [Match
failure] [(Text, Name, Int)]
variants
                      where
                        step :: (l, Name, a) -> [Match] -> [Match]
step (l
jsonName, Name
conName, a
members) [Match]
next =
                          case a
members of
                            a
0 ->
                              Pat -> Body -> [Dec] -> Match
Match
                                (Lit -> Pat
LitP (String -> Lit
StringL (forall l. IsList l => l -> [Item l]
toList l
jsonName)))
                                (Exp -> Body
NormalB Exp
bodyExp)
                                []
                                forall a. a -> [a] -> [a]
: [Match]
next
                              where
                                bodyExp :: Exp
bodyExp =
                                  Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) (Name -> Exp
ConE Name
conName)
                            a
_ -> [Match]
next

                        failure :: Match
failure =
                          Pat -> Body -> [Dec] -> Match
Match Pat
WildP (Exp -> Body
NormalB Exp
bodyExp) []
                          where
                            bodyExp :: Exp
bodyExp =
                              Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'fail) (Lit -> Exp
LitE (String -> Lit
StringL String
"Unexpected enum value"))

-- ** FromJSON Helpers

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

productParseJsonDec :: Name -> [(Text, Bool)] -> Dec
productParseJsonDec :: Name -> [(Text, Bool)] -> Dec
productParseJsonDec 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
VarE 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) (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 (forall a. a -> Maybe a
Just Exp
objectE) (Name -> Exp
VarE Name
opName) (forall a. a -> Maybe a
Just (Text -> Exp
textLitE Text
label))
      where
        opName :: Name
opName =
          if Bool
required
            then '(Ae..:)
            else '(Ae..:?)

sumObjectParserE :: Exp -> [(Text, Name, Int)] -> Exp
sumObjectParserE :: Exp -> [(Text, Name, Int)] -> Exp
sumObjectParserE Exp
objectE [(Text, Name, Int)]
variants =
  [(Text, Name, Int)] -> Exp
build [(Text, Name, Int)]
variants
  where
    build :: [(Text, Name, Int)] -> Exp
build = \case
      (Text
jsonName, Name
conName, Int
components) : [(Text, Name, Int)]
tail ->
        Exp -> [Match] -> Exp
CaseE
          ( Exp -> Exp -> Exp
AppE
              (Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'AeKeyMap.lookup) (Text -> Exp
textKeyE Text
jsonName))
              Exp
objectE
          )
          [ Pat -> Body -> [Dec] -> Match
Match
              (Name -> [Pat] -> Pat
Compat.conP 'Just [Name -> Pat
VarP (String -> Name
mkName String
"fieldValue")])
              ( Exp -> Body
NormalB
                  ( case Int
components of
                      Int
0 ->
                        Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'pure) (Name -> Exp
ConE Name
conName)
                      Int
1 ->
                        Exp -> [Exp] -> Exp
applicativeChainE
                          (Name -> Exp
ConE Name
conName)
                          [Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'Ae.parseJSON) (Name -> Exp
VarE (String -> Name
mkName String
"fieldValue"))]
                      Int
_ -> forall a. HasCallStack => String -> a
error String
"TODO: Handle multi-arity"
                  )
              )
              [],
            Pat -> Body -> [Dec] -> Match
Match
              (Name -> [Pat] -> Pat
Compat.conP 'Nothing [])
              (Exp -> Body
NormalB ([(Text, Name, Int)] -> Exp
build [(Text, Name, Int)]
tail))
              []
          ]
      [(Text, Name, Int)]
_ ->
        Exp -> Exp -> Exp
AppE
          (Name -> Exp
VarE 'fail)
          (Lit -> Exp
LitE (String -> Lit
StringL String
"No expected sum-type tag found"))

-- * ToJSON instance declaration

toJsonInstanceDec :: Type -> Dec -> Dec
toJsonInstanceDec :: Type -> Dec -> Dec
toJsonInstanceDec Type
type_ Dec
toJsonFunDec =
  Maybe Overlap -> Cxt -> Type -> [Dec] -> Dec
InstanceD 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_ 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_ 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_ forall a b. (a -> b) -> a -> b
$ [(Text, Name)] -> Dec
enumToJsonFunD [(Text, Name)]
members

-- ** ToJSON Helpers

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 =
      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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 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 (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 = 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 = Name
aName
                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 (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 (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Exp -> Exp
toJsonE 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 = 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

-- * Helpers

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) 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) 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)