{-# LANGUAGE CPP #-}
module Composite.Aeson.TH
( makeFieldJsonWrapper, makeFieldJsonWrapperExplicit
, makeRecordJsonWrapper, makeRecordJsonWrapperExplicit
) where
import Composite.Aeson.Base (JsonFormat, dimapJsonFormat, parseJsonWithFormat', toJsonWithFormat)
import Composite.Aeson.CoRecord (defaultJsonFormatField, fieldJsonFormat)
import Composite.Aeson.Formats.Default (DefaultJsonFormat, defaultJsonFormat)
import Composite.Aeson.Formats.Generic (SumStyle)
import Composite.Aeson.Record (defaultJsonFormatRecord, recordJsonFormat)
import Composite.CoRecord (Field)
import Composite.Record (Record)
import Control.Lens (_head, over)
import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))
import Data.Char (toLower)
import Language.Haskell.TH
( Q, clause, cxt
, normalB
, recC, varBangType, bang, bangType, noSourceUnpackedness, noSourceStrictness
, Dec, funD, instanceD, newtypeD, sigD, valD
, Exp, conE, varE
, Name, mkName, newName
, varP
, conT
)
import Language.Haskell.TH.Syntax (lift)
makeFieldJsonWrapper :: String -> Name -> SumStyle -> Q [Dec]
makeFieldJsonWrapper :: String -> Name -> SumStyle -> Q [Dec]
makeFieldJsonWrapper String
wrapperName Name
tyName SumStyle
sumStyle =
String -> Name -> SumStyle -> Q Exp -> Q [Dec]
makeFieldJsonWrapperExplicit String
wrapperName Name
tyName SumStyle
sumStyle [| defaultJsonFormatField |]
makeFieldJsonWrapperExplicit :: String -> Name -> SumStyle -> Q Exp -> Q [Dec]
makeFieldJsonWrapperExplicit :: String -> Name -> SumStyle -> Q Exp -> Q [Dec]
makeFieldJsonWrapperExplicit String
wrapperNameStr Name
fieldsTyName SumStyle
sumStyle Q Exp
fieldFormatExp = do
let wrapperName :: Name
wrapperName = String -> Name
mkName String
wrapperNameStr
extractorName :: Name
extractorName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"un" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
wrapperNameStr
fieldTy :: TypeQ
fieldTy = [t| Field $(conT fieldsTyName) |]
Name
formatName <- String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower String
wrapperNameStr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Format"
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> Q Dec
newtypeD
([TypeQ] -> CxtQ
cxt [])
Name
wrapperName
[]
Maybe Kind
forall a. Maybe a
Nothing
(Name -> [VarBangTypeQ] -> ConQ
recC Name
wrapperName [Name -> BangTypeQ -> VarBangTypeQ
varBangType Name
extractorName (BangQ -> TypeQ -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness) TypeQ
fieldTy)])
#if MIN_VERSION_template_haskell(2,12,0)
[]
#else
(cxt [])
#endif
, Name -> TypeQ -> Q Dec
sigD
Name
formatName
[t| forall e. JsonFormat e $(conT wrapperName) |]
, PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD
(Name -> PatQ
varP Name
formatName)
(Q Exp -> BodyQ
normalB [| dimapJsonFormat $(varE extractorName) $(conE wrapperName) (fieldJsonFormat $(lift sumStyle) $fieldFormatExp) |])
[]
, CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
([TypeQ] -> CxtQ
cxt [])
[t| DefaultJsonFormat $(conT wrapperName) |]
[ Name -> [ClauseQ] -> Q Dec
funD
'defaultJsonFormat
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
formatName) [] ]
]
, CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
([TypeQ] -> CxtQ
cxt [])
[t| FromJSON $(conT wrapperName) |]
[ Name -> [ClauseQ] -> Q Dec
funD
'parseJSON
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB [| parseJsonWithFormat' $(varE formatName) |]) [] ]
]
, CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
([TypeQ] -> CxtQ
cxt [])
[t| ToJSON $(conT wrapperName) |]
[ Name -> [ClauseQ] -> Q Dec
funD
'toJSON
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB [| toJsonWithFormat $(varE formatName) |]) [] ]
]
]
makeRecordJsonWrapper :: String -> Name -> Q [Dec]
makeRecordJsonWrapper :: String -> Name -> Q [Dec]
makeRecordJsonWrapper String
wrapperName Name
tyName =
String -> Name -> Q Exp -> Q [Dec]
makeRecordJsonWrapperExplicit String
wrapperName Name
tyName [| defaultJsonFormatRecord |]
makeRecordJsonWrapperExplicit :: String -> Name -> Q Exp -> Q [Dec]
makeRecordJsonWrapperExplicit :: String -> Name -> Q Exp -> Q [Dec]
makeRecordJsonWrapperExplicit String
wrapperNameStr Name
fieldsTyName Q Exp
recFormatExp = do
let wrapperName :: Name
wrapperName = String -> Name
mkName String
wrapperNameStr
extractorName :: Name
extractorName = String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"un" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
wrapperNameStr
recordTy :: TypeQ
recordTy = [t| Record $(conT fieldsTyName) |]
Name
formatName <- String -> Q Name
newName (String -> Q Name) -> String -> Q Name
forall a b. (a -> b) -> a -> b
$ ASetter String String Char Char
-> (Char -> Char) -> String -> String
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter String String Char Char
forall s a. Cons s s a a => Traversal' s a
_head Char -> Char
toLower String
wrapperNameStr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"Format"
[Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
[ CxtQ
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> ConQ
-> [DerivClauseQ]
-> Q Dec
newtypeD
([TypeQ] -> CxtQ
cxt [])
Name
wrapperName
[]
Maybe Kind
forall a. Maybe a
Nothing
(Name -> [VarBangTypeQ] -> ConQ
recC Name
wrapperName [Name -> BangTypeQ -> VarBangTypeQ
varBangType Name
extractorName (BangQ -> TypeQ -> BangTypeQ
bangType (SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang SourceUnpackednessQ
noSourceUnpackedness SourceStrictnessQ
noSourceStrictness) TypeQ
recordTy)])
#if MIN_VERSION_template_haskell(2,12,0)
[]
#else
(cxt [])
#endif
, Name -> TypeQ -> Q Dec
sigD
Name
formatName
[t| forall e. JsonFormat e $(conT wrapperName) |]
, PatQ -> BodyQ -> [Q Dec] -> Q Dec
valD
(Name -> PatQ
varP Name
formatName)
(Q Exp -> BodyQ
normalB [| dimapJsonFormat $(varE extractorName) $(conE wrapperName) (recordJsonFormat $recFormatExp) |])
[]
, CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
([TypeQ] -> CxtQ
cxt [])
[t| DefaultJsonFormat $(conT wrapperName) |]
[ Name -> [ClauseQ] -> Q Dec
funD
'defaultJsonFormat
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
varE Name
formatName) [] ]
]
, CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
([TypeQ] -> CxtQ
cxt [])
[t| FromJSON $(conT wrapperName) |]
[ Name -> [ClauseQ] -> Q Dec
funD
'parseJSON
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB [| parseJsonWithFormat' $(varE formatName) |]) [] ]
]
, CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD
([TypeQ] -> CxtQ
cxt [])
[t| ToJSON $(conT wrapperName) |]
[ Name -> [ClauseQ] -> Q Dec
funD
'toJSON
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (Q Exp -> BodyQ
normalB [| toJsonWithFormat $(varE formatName) |]) [] ]
]
]