module Composite.Aeson.TH
( makeRecJsonWrapper
, makeRecJsonWrapperExplicit
) where
import Composite.Aeson.Base (JsonFormat, dimapJsonFormat, parseJsonWithFormat', toJsonWithFormat)
import Composite.Aeson.Record (defaultJsonFormatRec, recJsonFormat)
import Composite.Record (Record)
import Control.Lens (_head, over)
import Data.Aeson (FromJSON(parseJSON), ToJSON(toJSON))
import Data.Char (toLower)
import Data.Monoid ((<>))
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
)
makeRecJsonWrapper :: String -> Name -> Q [Dec]
makeRecJsonWrapper wrapperName tyName =
makeRecJsonWrapperExplicit wrapperName tyName [| defaultJsonFormatRec |]
makeRecJsonWrapperExplicit :: String -> Name -> Q Exp -> Q [Dec]
makeRecJsonWrapperExplicit wrapperNameStr fieldsTyName recFormatExp = do
let wrapperName = mkName wrapperNameStr
extractorName = mkName $ "un" <> wrapperNameStr
recordTy = [t| Record $(conT fieldsTyName) |]
formatName <- newName $ over _head toLower wrapperNameStr <> "Format"
sequence
[ newtypeD
(cxt [])
wrapperName
[]
Nothing
(recC wrapperName [varBangType extractorName (bangType (bang noSourceUnpackedness noSourceStrictness) recordTy)])
(cxt [])
, sigD
formatName
[t| forall e. JsonFormat e $(conT wrapperName) |]
, valD
(varP formatName)
(normalB [| dimapJsonFormat $(varE extractorName) $(conE wrapperName) (recJsonFormat $recFormatExp) |])
[]
, instanceD
(cxt [])
[t| FromJSON $(conT wrapperName) |]
[ funD
'parseJSON
[ clause [] (normalB [| parseJsonWithFormat' $(varE formatName) |]) [] ]
]
, instanceD
(cxt [])
[t| ToJSON $(conT wrapperName) |]
[ funD
'toJSON
[ clause [] (normalB [| toJsonWithFormat $(varE formatName) |]) [] ]
]
]