{-# 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 wrapperName tyName sumStyle =
makeFieldJsonWrapperExplicit wrapperName tyName sumStyle [| defaultJsonFormatField |]
makeFieldJsonWrapperExplicit :: String -> Name -> SumStyle -> Q Exp -> Q [Dec]
makeFieldJsonWrapperExplicit wrapperNameStr fieldsTyName sumStyle fieldFormatExp = do
let wrapperName = mkName wrapperNameStr
extractorName = mkName $ "un" <> wrapperNameStr
fieldTy = [t| Field $(conT fieldsTyName) |]
formatName <- newName $ over _head toLower wrapperNameStr <> "Format"
sequence
[ newtypeD
(cxt [])
wrapperName
[]
Nothing
(recC wrapperName [varBangType extractorName (bangType (bang noSourceUnpackedness noSourceStrictness) fieldTy)])
#if MIN_VERSION_template_haskell(2,12,0)
[]
#else
(cxt [])
#endif
, sigD
formatName
[t| forall e. JsonFormat e $(conT wrapperName) |]
, valD
(varP formatName)
(normalB [| dimapJsonFormat $(varE extractorName) $(conE wrapperName) (fieldJsonFormat $(lift sumStyle) $fieldFormatExp) |])
[]
, instanceD
(cxt [])
[t| DefaultJsonFormat $(conT wrapperName) |]
[ funD
'defaultJsonFormat
[ clause [] (normalB $ varE formatName) [] ]
]
, 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) |]) [] ]
]
]
makeRecordJsonWrapper :: String -> Name -> Q [Dec]
makeRecordJsonWrapper wrapperName tyName =
makeRecordJsonWrapperExplicit wrapperName tyName [| defaultJsonFormatRecord |]
makeRecordJsonWrapperExplicit :: String -> Name -> Q Exp -> Q [Dec]
makeRecordJsonWrapperExplicit 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)])
#if MIN_VERSION_template_haskell(2,12,0)
[]
#else
(cxt [])
#endif
, sigD
formatName
[t| forall e. JsonFormat e $(conT wrapperName) |]
, valD
(varP formatName)
(normalB [| dimapJsonFormat $(varE extractorName) $(conE wrapperName) (recordJsonFormat $recFormatExp) |])
[]
, instanceD
(cxt [])
[t| DefaultJsonFormat $(conT wrapperName) |]
[ funD
'defaultJsonFormat
[ clause [] (normalB $ varE formatName) [] ]
]
, 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) |]) [] ]
]
]