#if __GLASGOW_HASKELL__ >= 800
#else
#endif
#include "incoherent-compat.h"
#include "overlapping-compat.h"
module Data.Aeson.TH
(
Options(..)
, SumEncoding(..)
, defaultOptions
, defaultTaggedObject
, deriveJSON
, deriveJSON1
, deriveJSON2
, deriveToJSON
, deriveToJSON1
, deriveToJSON2
, deriveFromJSON
, deriveFromJSON1
, deriveFromJSON2
, mkToJSON
, mkLiftToJSON
, mkLiftToJSON2
, mkToEncoding
, mkLiftToEncoding
, mkLiftToEncoding2
, mkParseJSON
, mkLiftParseJSON
, mkLiftParseJSON2
) where
import Prelude ()
import Prelude.Compat hiding (exp)
import Control.Applicative ((<|>))
import Data.Aeson (Object, (.=), (.:), FromJSON(..), FromJSON1(..), FromJSON2(..), ToJSON(..), ToJSON1(..), ToJSON2(..))
import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaultOptions, defaultTaggedObject)
import Data.Aeson.Types.Internal ((<?>), Pair, JSONPathElement(Key))
import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
import Control.Monad (liftM2, unless, when)
import Data.Foldable (foldr')
#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
import Data.List (nub)
#endif
import Data.List (find, foldl', genericLength , intercalate , intersperse, partition, union)
import Data.List.NonEmpty ((<|), NonEmpty((:|)))
import Data.Map (Map)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Set (Set)
#if MIN_VERSION_template_haskell(2,8,0)
import Language.Haskell.TH hiding (Arity)
#else
import Language.Haskell.TH
#endif
import Language.Haskell.TH.Syntax (VarStrictType)
#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))
import Language.Haskell.TH.Lib (starK)
#endif
#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))
import Language.Haskell.TH.Syntax (mkNameG_tc)
#endif
import Text.Printf (printf)
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding.Internal as E
import qualified Data.Foldable as F (all)
import qualified Data.HashMap.Strict as H (lookup, toList)
import qualified Data.List.NonEmpty as NE (drop, length, reverse, splitAt)
import qualified Data.Map as M (fromList, findWithDefault, keys, lookup , singleton, size)
import qualified Data.Set as Set (empty, insert, member)
import qualified Data.Text as T (Text, pack, unpack)
import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)
import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)
deriveJSON :: Options
-> Name
-> Q [Dec]
deriveJSON = deriveJSONBoth deriveToJSON deriveFromJSON
deriveJSON1 :: Options
-> Name
-> Q [Dec]
deriveJSON1 = deriveJSONBoth deriveToJSON1 deriveFromJSON1
deriveJSON2 :: Options
-> Name
-> Q [Dec]
deriveJSON2 = deriveJSONBoth deriveToJSON2 deriveFromJSON2
deriveToJSON :: Options
-> Name
-> Q [Dec]
deriveToJSON = deriveToJSONCommon toJSONClass
deriveToJSON1 :: Options
-> Name
-> Q [Dec]
deriveToJSON1 = deriveToJSONCommon toJSON1Class
deriveToJSON2 :: Options
-> Name
-> Q [Dec]
deriveToJSON2 = deriveToJSONCommon toJSON2Class
deriveToJSONCommon :: JSONClass
-> Options
-> Name
-> Q [Dec]
deriveToJSONCommon = deriveJSONClass [ (ToJSON, \jc _ -> consToValue jc)
, (ToEncoding, \jc _ -> consToEncoding jc)
]
mkToJSON :: Options
-> Name
-> Q Exp
mkToJSON = mkToJSONCommon toJSONClass
mkLiftToJSON :: Options
-> Name
-> Q Exp
mkLiftToJSON = mkToJSONCommon toJSON1Class
mkLiftToJSON2 :: Options
-> Name
-> Q Exp
mkLiftToJSON2 = mkToJSONCommon toJSON2Class
mkToJSONCommon :: JSONClass
-> Options
-> Name
-> Q Exp
mkToJSONCommon = mkFunCommon (\jc _ -> consToValue jc)
mkToEncoding :: Options
-> Name
-> Q Exp
mkToEncoding = mkToEncodingCommon toJSONClass
mkLiftToEncoding :: Options
-> Name
-> Q Exp
mkLiftToEncoding = mkToEncodingCommon toJSON1Class
mkLiftToEncoding2 :: Options
-> Name
-> Q Exp
mkLiftToEncoding2 = mkToEncodingCommon toJSON2Class
mkToEncodingCommon :: JSONClass
-> Options
-> Name
-> Q Exp
mkToEncodingCommon = mkFunCommon (\jc _ -> consToEncoding jc)
consToValue :: JSONClass
-> Options
-> [Con]
-> Q Exp
consToValue _ _ [] = error $ "Data.Aeson.TH.consToValue: "
++ "Not a single constructor given!"
consToValue jc opts cons = do
value <- newName "value"
tjs <- newNameList "_tj" $ arityInt jc
tjls <- newNameList "_tjl" $ arityInt jc
let zippedTJs = zip tjs tjls
interleavedTJs = interleave tjs tjls
lamE (map varP $ interleavedTJs ++ [value]) $
caseE (varE value) (matches zippedTJs)
where
matches tjs = case cons of
[con] -> [argsToValue jc tjs opts False con]
_ | allNullaryToStringTag opts && all isNullary cons ->
[ match (conP conName []) (normalB $ conStr opts conName) []
| con <- cons
, let conName = getConName con
]
| otherwise -> [argsToValue jc tjs opts True con | con <- cons]
conStr :: Options -> Name -> Q Exp
conStr opts = appE [|String|] . conTxt opts
conTxt :: Options -> Name -> Q Exp
conTxt opts = appE [|T.pack|] . conStringE opts
conStringE :: Options -> Name -> Q Exp
conStringE opts = stringE . constructorTagModifier opts . nameBase
consToEncoding :: JSONClass
-> Options
-> [Con]
-> Q Exp
consToEncoding _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "
++ "Not a single constructor given!"
consToEncoding jc opts cons = do
value <- newName "value"
tes <- newNameList "_te" $ arityInt jc
tels <- newNameList "_tel" $ arityInt jc
let zippedTEs = zip tes tels
interleavedTEs = interleave tes tels
lamE (map varP $ interleavedTEs ++ [value]) $
caseE (varE value) (matches zippedTEs)
where
matches tes = case cons of
[con] -> [argsToEncoding jc tes opts False con]
_ | allNullaryToStringTag opts && all isNullary cons ->
[ match (conP conName [])
(normalB $ encStr opts conName) []
| con <- cons
, let conName = getConName con
]
| otherwise -> [argsToEncoding jc tes opts True con | con <- cons]
encStr :: Options -> Name -> Q Exp
encStr opts = appE [|E.text|] . conTxt opts
isNullary :: Con -> Bool
isNullary (NormalC _ []) = True
isNullary _ = False
sumToValue :: Options -> Bool -> Name -> Q Exp -> Q Exp
sumToValue opts multiCons conName exp
| multiCons =
case sumEncoding opts of
TwoElemArray ->
[|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp])
TaggedObject{tagFieldName, contentsFieldName} ->
[|A.object|] `appE` listE
[ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
, infixApp [|T.pack contentsFieldName|] [|(.=)|] exp
]
ObjectWithSingleField ->
[|A.object|] `appE` listE
[ infixApp (conTxt opts conName) [|(.=)|] exp
]
UntaggedValue -> exp
| otherwise = exp
nullarySumToValue :: Options -> Bool -> Name -> Q Exp
nullarySumToValue opts multiCons conName =
case sumEncoding opts of
TaggedObject{tagFieldName} ->
[|A.object|] `appE` listE
[ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName)
]
UntaggedValue -> conStr opts conName
_ -> sumToValue opts multiCons conName [e|toJSON ([] :: [()])|]
argsToValue :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match
argsToValue jc tjs opts multiCons (NormalC conName []) = do
([], _) <- reifyConTys jc tjs conName
match (conP conName [])
(normalB (nullarySumToValue opts multiCons conName))
[]
argsToValue jc tjs opts multiCons (NormalC conName ts) = do
(argTys, tvMap) <- reifyConTys jc tjs conName
let len = length ts
args <- newNameList "arg" len
js <- case [ dispatchToJSON jc conName tvMap argTy
`appE` varE arg
| (arg, argTy) <- zip args argTys
] of
[e] -> return e
es -> do
mv <- newName "mv"
let newMV = bindS (varP mv)
([|VM.unsafeNew|] `appE`
litE (integerL $ fromIntegral len))
stmts = [ noBindS $
[|VM.unsafeWrite|] `appE`
varE mv `appE`
litE (integerL ix) `appE`
e
| (ix, e) <- zip [(0::Integer)..] es
]
ret = noBindS $ [|return|] `appE` varE mv
return $ [|Array|] `appE`
(varE 'V.create `appE`
doE (newMV:stmts++[ret]))
match (conP conName $ map varP args)
(normalB $ sumToValue opts multiCons conName js)
[]
argsToValue jc tjs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
(True,True,[(_,st,ty)]) -> argsToValue jc tjs opts multiCons (NormalC conName [(st,ty)])
_ -> do
(argTys, tvMap) <- reifyConTys jc tjs conName
args <- newNameList "arg" $ length ts
let exp = [|A.object|] `appE` pairs
pairs | omitNothingFields opts = infixApp maybeFields
[|(++)|]
restFields
| otherwise = listE $ map toPair argCons
argCons = zip3 args argTys ts
maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
restFields = listE $ map toPair rest
(maybes, rest) = partition isMaybe argCons
maybeToPair (arg, argTy, (field, _, _)) =
infixApp ([|keyValuePairWith|]
`appE` dispatchToJSON jc conName tvMap argTy
`appE` toFieldName field)
[|(<$>)|]
(varE arg)
toPair (arg, argTy, (field, _, _)) =
[|keyValuePairWith|]
`appE` dispatchToJSON jc conName tvMap argTy
`appE` toFieldName field
`appE` varE arg
toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
match (conP conName $ map varP args)
( normalB
$ if multiCons
then case sumEncoding opts of
TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
TaggedObject{tagFieldName} ->
[|A.object|] `appE`
infixApp (infixApp [|T.pack tagFieldName|]
[|(.=)|]
(conStr opts conName))
[|(:)|]
pairs
ObjectWithSingleField ->
[|A.object|] `appE` listE
[ infixApp (conTxt opts conName) [|(.=)|] exp ]
UntaggedValue -> exp
else exp
) []
argsToValue jc tjs opts multiCons (InfixC _ conName _) = do
([alTy, arTy], tvMap) <- reifyConTys jc tjs conName
al <- newName "argL"
ar <- newName "argR"
match (infixP (varP al) conName (varP ar))
( normalB
$ sumToValue opts multiCons conName
$ [|toJSON|] `appE` listE [ dispatchToJSON jc conName tvMap aTy
`appE` varE a
| (a, aTy) <- [(al,alTy), (ar,arTy)]
]
)
[]
argsToValue jc tjs opts multiCons (ForallC _ _ con) =
argsToValue jc tjs opts multiCons con
#if MIN_VERSION_template_haskell(2,11,0)
argsToValue jc tjs opts multiCons (GadtC conNames ts _) =
argsToValue jc tjs opts multiCons $ NormalC (head conNames) ts
argsToValue jc tjs opts multiCons (RecGadtC conNames ts _) =
argsToValue jc tjs opts multiCons $ RecC (head conNames) ts
#endif
isMaybe :: (a, b, (c, d, Type)) -> Bool
isMaybe (_, _, (_, _, AppT (ConT t) _)) = t == ''Maybe
isMaybe _ = False
(<^>) :: ExpQ -> ExpQ -> ExpQ
(<^>) a b = infixApp a [|(E.><)|] b
infixr 6 <^>
(<:>) :: ExpQ -> ExpQ -> ExpQ
(<:>) a b = a <^> [|E.colon|] <^> b
infixr 5 <:>
(<%>) :: ExpQ -> ExpQ -> ExpQ
(<%>) a b = a <^> [|E.comma|] <^> b
infixr 4 <%>
array :: ExpQ -> ExpQ
array exp = [|E.wrapArray|] `appE` exp
object :: ExpQ -> ExpQ
object exp = [|E.wrapObject|] `appE` exp
sumToEncoding :: Options -> Bool -> Name -> Q Exp -> Q Exp
sumToEncoding opts multiCons conName exp
| multiCons =
let fexp = exp in
case sumEncoding opts of
TwoElemArray ->
array (encStr opts conName <%> fexp)
TaggedObject{tagFieldName, contentsFieldName} ->
object $
([|E.text (T.pack tagFieldName)|] <:> encStr opts conName) <%>
([|E.text (T.pack contentsFieldName)|] <:> fexp)
ObjectWithSingleField ->
object (encStr opts conName <:> fexp)
UntaggedValue -> exp
| otherwise = exp
nullarySumToEncoding :: Options -> Bool -> Name -> Q Exp
nullarySumToEncoding opts multiCons conName =
case sumEncoding opts of
TaggedObject{tagFieldName} ->
object $
[|E.text (T.pack tagFieldName)|] <:> encStr opts conName
UntaggedValue -> encStr opts conName
_ -> sumToEncoding opts multiCons conName [e|toEncoding ([] :: [()])|]
argsToEncoding :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match
argsToEncoding jc tes opts multiCons (NormalC conName []) = do
([], _) <- reifyConTys jc tes conName
match (conP conName [])
(normalB (nullarySumToEncoding opts multiCons conName))
[]
argsToEncoding jc tes opts multiCons (NormalC conName ts) = do
(argTys, tvMap) <- reifyConTys jc tes conName
let len = length ts
args <- newNameList "arg" len
js <- case zip args argTys of
[(e,eTy)] -> return (dispatchToEncoding jc conName tvMap eTy
`appE` varE e)
es ->
return (array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap xTy
`appE` varE x
| (x,xTy) <- es
]))
match (conP conName $ map varP args)
(normalB $ sumToEncoding opts multiCons conName js)
[]
argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
(True,True,[(_,st,ty)]) -> argsToEncoding jc tes opts multiCons (NormalC conName [(st,ty)])
_ -> do
args <- newNameList "arg" $ length ts
(argTys, tvMap) <- reifyConTys jc tes conName
let exp = object objBody
objBody = [|E.econcat|] `appE`
([|intersperse E.comma|] `appE` pairs)
pairs | omitNothingFields opts = infixApp maybeFields
[|(++)|]
restFields
| otherwise = listE (map toPair argCons)
argCons = zip3 args argTys ts
maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
restFields = listE (map toPair rest)
(maybes, rest) = partition isMaybe argCons
maybeToPair (arg, argTy, (field, _, _)) =
infixApp
(infixApp
(infixE
(Just $ toFieldName field <^> [|E.colon|])
[|(E.><)|]
Nothing)
[|(.)|]
(dispatchToEncoding jc conName tvMap argTy))
[|(<$>)|]
(varE arg)
toPair (arg, argTy, (field, _, _)) =
toFieldName field
<:> dispatchToEncoding jc conName tvMap argTy
`appE` varE arg
toFieldName field = [|E.text|] `appE`
([|T.pack|] `appE` fieldLabelExp opts field)
match (conP conName $ map varP args)
( normalB
$ if multiCons
then case sumEncoding opts of
TwoElemArray -> array $
encStr opts conName <%> exp
TaggedObject{tagFieldName} -> object $
([|E.text (T.pack tagFieldName)|] <:>
encStr opts conName) <%>
objBody
ObjectWithSingleField -> object $
encStr opts conName <:> exp
UntaggedValue -> exp
else exp
) []
argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do
al <- newName "argL"
ar <- newName "argR"
([alTy,arTy], tvMap) <- reifyConTys jc tes conName
match (infixP (varP al) conName (varP ar))
( normalB
$ sumToEncoding opts multiCons conName
$ array (foldr1 (<%>) [ dispatchToEncoding jc conName tvMap aTy
`appE` varE a
| (a,aTy) <- [(al,alTy), (ar,arTy)]
])
)
[]
argsToEncoding jc tes opts multiCons (ForallC _ _ con) =
argsToEncoding jc tes opts multiCons con
#if MIN_VERSION_template_haskell(2,11,0)
argsToEncoding jc tes opts multiCons (GadtC conNames ts _) =
argsToEncoding jc tes opts multiCons $ NormalC (head conNames) ts
argsToEncoding jc tes opts multiCons (RecGadtC conNames ts _) =
argsToEncoding jc tes opts multiCons $ RecC (head conNames) ts
#endif
deriveFromJSON :: Options
-> Name
-> Q [Dec]
deriveFromJSON = deriveFromJSONCommon fromJSONClass
deriveFromJSON1 :: Options
-> Name
-> Q [Dec]
deriveFromJSON1 = deriveFromJSONCommon fromJSON1Class
deriveFromJSON2 :: Options
-> Name
-> Q [Dec]
deriveFromJSON2 = deriveFromJSONCommon fromJSON2Class
deriveFromJSONCommon :: JSONClass
-> Options
-> Name
-> Q [Dec]
deriveFromJSONCommon = deriveJSONClass [(ParseJSON, consFromJSON)]
mkParseJSON :: Options
-> Name
-> Q Exp
mkParseJSON = mkParseJSONCommon fromJSONClass
mkLiftParseJSON :: Options
-> Name
-> Q Exp
mkLiftParseJSON = mkParseJSONCommon fromJSON1Class
mkLiftParseJSON2 :: Options
-> Name
-> Q Exp
mkLiftParseJSON2 = mkParseJSONCommon fromJSON2Class
mkParseJSONCommon :: JSONClass
-> Options
-> Name
-> Q Exp
mkParseJSONCommon = mkFunCommon consFromJSON
consFromJSON :: JSONClass
-> Name
-> Options
-> [Con]
-> Q Exp
consFromJSON _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
++ "Not a single constructor given!"
consFromJSON jc tName opts cons = do
value <- newName "value"
pjs <- newNameList "_pj" $ arityInt jc
pjls <- newNameList "_pjl" $ arityInt jc
let zippedPJs = zip pjs pjls
interleavedPJs = interleave pjs pjls
lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value zippedPJs
where
lamExpr value pjs = case cons of
[con] -> parseArgs jc pjs tName opts con (Right value)
_ | sumEncoding opts == UntaggedValue
-> parseUntaggedValue pjs cons value
| otherwise
-> caseE (varE value) $
if allNullaryToStringTag opts && all isNullary cons
then allNullaryMatches
else mixedMatches pjs
allNullaryMatches =
[ do txt <- newName "txt"
match (conP 'String [varP txt])
(guardedB $
[ liftM2 (,) (normalG $
infixApp (varE txt)
[|(==)|]
([|T.pack|] `appE`
conStringE opts conName)
)
([|pure|] `appE` conE conName)
| con <- cons
, let conName = getConName con
]
++
[ liftM2 (,)
(normalG [|otherwise|])
( [|noMatchFail|]
`appE` litE (stringL $ show tName)
`appE` ([|T.unpack|] `appE` varE txt)
)
]
)
[]
, do other <- newName "other"
match (varP other)
(normalB $ [|noStringFail|]
`appE` litE (stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
mixedMatches pjs =
case sumEncoding opts of
TaggedObject {tagFieldName, contentsFieldName} ->
parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName
UntaggedValue -> error "UntaggedValue: Should be handled already"
ObjectWithSingleField ->
parseObject $ parseObjectWithSingleField pjs
TwoElemArray ->
[ do arr <- newName "array"
match (conP 'Array [varP arr])
(guardedB
[ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
[|(==)|]
(litE $ integerL 2))
(parse2ElemArray pjs arr)
, liftM2 (,) (normalG [|otherwise|])
([|not2ElemArray|]
`appE` litE (stringL $ show tName)
`appE` ([|V.length|] `appE` varE arr))
]
)
[]
, do other <- newName "other"
match (varP other)
( normalB
$ [|noArrayFail|]
`appE` litE (stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
parseObject f =
[ do obj <- newName "obj"
match (conP 'Object [varP obj]) (normalB $ f obj) []
, do other <- newName "other"
match (varP other)
( normalB
$ [|noObjectFail|]
`appE` litE (stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
parseTaggedObject pjs typFieldName valFieldName obj = do
conKey <- newName "conKey"
doE [ bindS (varP conKey)
(infixApp (varE obj)
[|(.:)|]
([|T.pack|] `appE` stringE typFieldName))
, noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
]
parseUntaggedValue pjs cons' conVal =
foldr1 (\e e' -> infixApp e [|(<|>)|] e')
(map (\x -> parseValue pjs x conVal) cons')
parseValue _pjs (NormalC conName []) conVal = do
str <- newName "str"
caseE (varE conVal)
[ match (conP 'String [varP str])
(guardedB
[ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] ([|T.pack|] `appE` conStringE opts conName)
)
([|pure|] `appE` conE conName)
]
)
[]
, matchFailed tName conName "String"
]
parseValue pjs con conVal =
parseArgs jc pjs tName opts con (Right conVal)
parse2ElemArray pjs arr = do
conKey <- newName "conKey"
conVal <- newName "conVal"
let letIx n ix =
valD (varP n)
(normalB ([|V.unsafeIndex|] `appE`
varE arr `appE`
litE (integerL ix)))
[]
letE [ letIx conKey 0
, letIx conVal 1
]
(caseE (varE conKey)
[ do txt <- newName "txt"
match (conP 'String [varP txt])
(normalB $ parseContents pjs
txt
(Right conVal)
'conNotFoundFail2ElemArray
)
[]
, do other <- newName "other"
match (varP other)
( normalB
$ [|firstElemNoStringFail|]
`appE` litE (stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
)
parseObjectWithSingleField pjs obj = do
conKey <- newName "conKey"
conVal <- newName "conVal"
caseE ([e|H.toList|] `appE` varE obj)
[ match (listP [tupP [varP conKey, varP conVal]])
(normalB $ parseContents pjs conKey (Right conVal) 'conNotFoundFailObjectSingleField)
[]
, do other <- newName "other"
match (varP other)
(normalB $ [|wrongPairCountFail|]
`appE` litE (stringL $ show tName)
`appE` ([|show . length|] `appE` varE other)
)
[]
]
parseContents pjs conKey contents errorFun =
caseE (varE conKey)
[ match wildP
( guardedB $
[ do g <- normalG $ infixApp (varE conKey)
[|(==)|]
([|T.pack|] `appE`
conNameExp opts con)
e <- parseArgs jc pjs tName opts con contents
return (g, e)
| con <- cons
]
++
[ liftM2 (,)
(normalG [e|otherwise|])
( varE errorFun
`appE` litE (stringL $ show tName)
`appE` listE (map ( litE
. stringL
. constructorTagModifier opts
. nameBase
. getConName
) cons
)
`appE` ([|T.unpack|] `appE` varE conKey)
)
]
)
[]
]
parseNullaryMatches :: Name -> Name -> [Q Match]
parseNullaryMatches tName conName =
[ do arr <- newName "arr"
match (conP 'Array [varP arr])
(guardedB
[ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr)
([|pure|] `appE` conE conName)
, liftM2 (,) (normalG [|otherwise|])
(parseTypeMismatch tName conName
(litE $ stringL "an empty Array")
(infixApp (litE $ stringL "Array of length ")
[|(++)|]
([|show . V.length|] `appE` varE arr)
)
)
]
)
[]
, matchFailed tName conName "Array"
]
parseUnaryMatches :: JSONClass -> TyVarMap -> Type -> Name -> [Q Match]
parseUnaryMatches jc tvMap argTy conName =
[ do arg <- newName "arg"
match (varP arg)
( normalB $ infixApp (conE conName)
[|(<$>)|]
(dispatchParseJSON jc conName tvMap argTy
`appE` varE arg)
)
[]
]
parseRecord :: JSONClass
-> TyVarMap
-> [Type]
-> Options
-> Name
-> Name
-> [VarStrictType]
-> Name
-> ExpQ
parseRecord jc tvMap argTys opts tName conName ts obj =
foldl' (\a b -> infixApp a [|(<*>)|] b)
(infixApp (conE conName) [|(<$>)|] x)
xs
where
x:xs = [ [|lookupField|]
`appE` dispatchParseJSON jc conName tvMap argTy
`appE` litE (stringL $ show tName)
`appE` litE (stringL $ constructorTagModifier opts $ nameBase conName)
`appE` varE obj
`appE` ( [|T.pack|] `appE` fieldLabelExp opts field
)
| ((field, _, _), argTy) <- zip ts argTys
]
getValField :: Name -> String -> [MatchQ] -> Q Exp
getValField obj valFieldName matches = do
val <- newName "val"
doE [ bindS (varP val) $ infixApp (varE obj)
[|(.:)|]
([|T.pack|] `appE`
litE (stringL valFieldName))
, noBindS $ caseE (varE val) matches
]
matchCases :: Either (String, Name) Name -> [MatchQ] -> Q Exp
matchCases (Left (valFieldName, obj)) = getValField obj valFieldName
matchCases (Right valName) = caseE (varE valName)
parseArgs :: JSONClass
-> [(Name, Name)]
-> Name
-> Options
-> Con
-> Either (String, Name) Name
-> Q Exp
parseArgs jc pjs _ _ (NormalC conName []) (Left _) = do
([], _) <- reifyConTys jc pjs conName
[|pure|] `appE` conE conName
parseArgs jc pjs tName _ (NormalC conName []) (Right valName) = do
([], _) <- reifyConTys jc pjs conName
caseE (varE valName) $ parseNullaryMatches tName conName
parseArgs jc pjs _ _ (NormalC conName [_]) contents = do
([argTy], tvMap) <- reifyConTys jc pjs conName
matchCases contents $ parseUnaryMatches jc tvMap argTy conName
parseArgs jc pjs tName _ (NormalC conName ts) contents = do
(argTys, tvMap) <- reifyConTys jc pjs conName
let len = genericLength ts
matchCases contents $ parseProduct jc tvMap argTys tName conName len
parseArgs jc pjs tName opts (RecC conName ts) (Left (_, obj)) = do
(argTys, tvMap) <- reifyConTys jc pjs conName
parseRecord jc tvMap argTys opts tName conName ts obj
parseArgs jc pjs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of
(True,[(_,st,ty)])-> parseArgs jc pjs tName opts (NormalC conName [(st,ty)]) (Right valName)
_ -> do
obj <- newName "recObj"
(argTys, tvMap) <- reifyConTys jc pjs conName
caseE (varE valName)
[ match (conP 'Object [varP obj]) (normalB $
parseRecord jc tvMap argTys opts tName conName ts obj) []
, matchFailed tName conName "Object"
]
parseArgs jc pjs tName _ (InfixC _ conName _) contents = do
(argTys, tvMap) <- reifyConTys jc pjs conName
matchCases contents $ parseProduct jc tvMap argTys tName conName 2
parseArgs jc pjs tName opts (ForallC _ _ con) contents =
parseArgs jc pjs tName opts con contents
#if MIN_VERSION_template_haskell(2,11,0)
parseArgs jc pjs tName opts (GadtC conNames ts _) contents =
parseArgs jc pjs tName opts (NormalC (head conNames) ts) contents
parseArgs jc pjs tName opts (RecGadtC conNames ts _) contents =
parseArgs jc pjs tName opts (RecC (head conNames) ts) contents
#endif
parseProduct :: JSONClass
-> TyVarMap
-> [Type]
-> Name
-> Name
-> Integer
-> [Q Match]
parseProduct jc tvMap argTys tName conName numArgs =
[ do arr <- newName "arr"
let x:xs = [ dispatchParseJSON jc conName tvMap argTy
`appE`
infixApp (varE arr)
[|V.unsafeIndex|]
(litE $ integerL ix)
| (argTy, ix) <- zip argTys [0 .. numArgs 1]
]
match (conP 'Array [varP arr])
(normalB $ condE ( infixApp ([|V.length|] `appE` varE arr)
[|(==)|]
(litE $ integerL numArgs)
)
( foldl' (\a b -> infixApp a [|(<*>)|] b)
(infixApp (conE conName) [|(<$>)|] x)
xs
)
( parseTypeMismatch tName conName
(litE $ stringL $ "Array of length " ++ show numArgs)
( infixApp (litE $ stringL "Array of length ")
[|(++)|]
([|show . V.length|] `appE` varE arr)
)
)
)
[]
, matchFailed tName conName "Array"
]
matchFailed :: Name -> Name -> String -> MatchQ
matchFailed tName conName expected = do
other <- newName "other"
match (varP other)
( normalB $ parseTypeMismatch tName conName
(litE $ stringL expected)
([|valueConName|] `appE` varE other)
)
[]
parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ
parseTypeMismatch tName conName expected actual =
foldl appE
[|parseTypeMismatch'|]
[ litE $ stringL $ nameBase conName
, litE $ stringL $ show tName
, expected
, actual
]
class LookupField a where
lookupField :: (Value -> Parser a) -> String -> String
-> Object -> T.Text -> Parser a
instance OVERLAPPABLE_ LookupField a where
lookupField = lookupFieldWith
instance INCOHERENT_ LookupField (Maybe a) where
lookupField pj _ _ = parseOptionalFieldWith pj
lookupFieldWith :: (Value -> Parser a) -> String -> String
-> Object -> T.Text -> Parser a
lookupFieldWith pj tName rec obj key =
case H.lookup key obj of
Nothing -> unknownFieldFail tName rec (T.unpack key)
Just v -> pj v <?> Key key
keyValuePairWith :: (v -> Value) -> T.Text -> v -> Pair
keyValuePairWith tj name value = (name, tj value)
unknownFieldFail :: String -> String -> String -> Parser fail
unknownFieldFail tName rec key =
fail $ printf "When parsing the record %s of type %s the key %s was not present."
rec tName key
noArrayFail :: String -> String -> Parser fail
noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o
noObjectFail :: String -> String -> Parser fail
noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o
firstElemNoStringFail :: String -> String -> Parser fail
firstElemNoStringFail t o = fail $ printf "When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." t o
wrongPairCountFail :: String -> String -> Parser fail
wrongPairCountFail t n =
fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs."
t n
noStringFail :: String -> String -> Parser fail
noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o
noMatchFail :: String -> String -> Parser fail
noMatchFail t o =
fail $ printf "When parsing %s expected a String with the tag of a constructor but got %s." t o
not2ElemArray :: String -> Int -> Parser fail
not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2 elements but got %i elements" t i
conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail
conNotFoundFail2ElemArray t cs o =
fail $ printf "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s."
t (intercalate ", " cs) o
conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail
conNotFoundFailObjectSingleField t cs o =
fail $ printf "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s."
t (intercalate ", " cs) o
conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser fail
conNotFoundFailTaggedObject t cs o =
fail $ printf "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s."
t (intercalate ", " cs) o
parseTypeMismatch' :: String -> String -> String -> String -> Parser fail
parseTypeMismatch' conName tName expected actual =
fail $ printf "When parsing the constructor %s of type %s expected %s but got %s."
conName tName expected actual
deriveJSONBoth :: (Options -> Name -> Q [Dec])
-> (Options -> Name -> Q [Dec])
-> Options
-> Name
-> Q [Dec]
deriveJSONBoth dtj dfj opts name =
liftM2 (++) (dtj opts name) (dfj opts name)
deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]
-> JSONClass
-> Options
-> Name
-> Q [Dec]
deriveJSONClass consFuns jc opts name =
withType name $ \name' ctxt tvbs cons mbTys ->
(:[]) <$> fromCons name' ctxt tvbs cons mbTys
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
fromCons name' ctxt tvbs cons mbTys = do
(instanceCxt, instanceType)
<- buildTypeInstance name' jc ctxt tvbs mbTys
instanceD (return instanceCxt)
(return instanceType)
(methodDecs name' cons)
methodDecs :: Name -> [Con] -> [Q Dec]
methodDecs name' cons = flip map consFuns $ \(jf, jfMaker) ->
funD (jsonFunValName jf (arity jc))
[ clause []
(normalB $ jfMaker jc name' opts cons)
[]
]
mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)
-> JSONClass
-> Options
-> Name
-> Q Exp
mkFunCommon consFun jc opts name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
fromCons name' ctxt tvbs cons mbTys = do
!_ <- buildTypeInstance name' jc ctxt tvbs mbTys
consFun jc name' opts cons
dispatchFunByType :: JSONClass
-> JSONFun
-> Name
-> TyVarMap
-> Bool
-> Type
-> Q Exp
dispatchFunByType _ jf _ tvMap list (VarT tyName) =
varE $ case M.lookup tyName tvMap of
Just (tfjExp, tfjlExp) -> if list then tfjlExp else tfjExp
Nothing -> jsonFunValOrListName list jf Arity0
dispatchFunByType jc jf conName tvMap list (SigT ty _) =
dispatchFunByType jc jf conName tvMap list ty
dispatchFunByType jc jf conName tvMap list (ForallT _ _ ty) =
dispatchFunByType jc jf conName tvMap list ty
dispatchFunByType jc jf conName tvMap list ty = do
let tyCon :: Type
tyArgs :: [Type]
tyCon :| tyArgs = unapplyTy ty
numLastArgs :: Int
numLastArgs = min (arityInt jc) (length tyArgs)
lhsArgs, rhsArgs :: [Type]
(lhsArgs, rhsArgs) = splitAt (length tyArgs numLastArgs) tyArgs
tyVarNames :: [Name]
tyVarNames = M.keys tvMap
itf <- isTyFamily tyCon
if any (`mentionsName` tyVarNames) lhsArgs
|| itf && any (`mentionsName` tyVarNames) tyArgs
then outOfPlaceTyVarError jc conName
else if any (`mentionsName` tyVarNames) rhsArgs
then appsE $ varE (jsonFunValOrListName list jf $ toEnum numLastArgs)
: zipWith (dispatchFunByType jc jf conName tvMap)
(cycle [False,True])
(interleave rhsArgs rhsArgs)
else varE $ jsonFunValOrListName list jf Arity0
dispatchToJSON, dispatchToEncoding, dispatchParseJSON
:: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
dispatchToJSON jc n tvMap = dispatchFunByType jc ToJSON n tvMap False
dispatchToEncoding jc n tvMap = dispatchFunByType jc ToEncoding n tvMap False
dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False
withType :: Name
-> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)
-> Q a
withType name f = do
info <- reify name
case info of
TyConI dec ->
case dec of
#if MIN_VERSION_template_haskell(2,11,0)
DataD ctxt _ tvbs _ cons _ -> f name ctxt tvbs cons Nothing
NewtypeD ctxt _ tvbs _ con _ -> f name ctxt tvbs [con] Nothing
#else
DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing
NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing
#endif
other -> fail $ ns ++ "Unsupported type: " ++ show other
#if MIN_VERSION_template_haskell(2,11,0)
DataConI _ _ parentName -> do
#else
DataConI _ _ parentName _ -> do
#endif
parentInfo <- reify parentName
case parentInfo of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI (DataFamilyD _ tvbs _) decs ->
#else
FamilyI (FamilyD DataFam _ tvbs _) decs ->
#endif
let instDec = flip find decs $ \dec -> case dec of
#if MIN_VERSION_template_haskell(2,11,0)
DataInstD _ _ _ _ cons _ -> any ((name ==) . getConName) cons
NewtypeInstD _ _ _ _ con _ -> name == getConName con
#else
DataInstD _ _ _ cons _ -> any ((name ==) . getConName) cons
NewtypeInstD _ _ _ con _ -> name == getConName con
#endif
_ -> error $ ns ++ "Must be a data or newtype instance."
in case instDec of
#if MIN_VERSION_template_haskell(2,11,0)
Just (DataInstD ctxt _ instTys _ cons _) -> f parentName ctxt tvbs cons $ Just instTys
Just (NewtypeInstD ctxt _ instTys _ con _) -> f parentName ctxt tvbs [con] $ Just instTys
#else
Just (DataInstD ctxt _ instTys cons _) -> f parentName ctxt tvbs cons $ Just instTys
Just (NewtypeInstD ctxt _ instTys con _) -> f parentName ctxt tvbs [con] $ Just instTys
#endif
_ -> fail $ ns ++
"Could not find data or newtype instance constructor."
_ -> fail $ ns ++ "Data constructor " ++ show name ++
" is not from a data family instance constructor."
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI DataFamilyD{} _ ->
#else
FamilyI (FamilyD DataFam _ _ _) _ ->
#endif
fail $ ns ++
"Cannot use a data family name. Use a data family instance constructor instead."
_ -> fail $ ns ++ "I need the name of a plain data type constructor, "
++ "or a data family instance constructor."
where
ns :: String
ns = "Data.Aeson.TH.withType: "
buildTypeInstance :: Name
-> JSONClass
-> Cxt
-> [TyVarBndr]
-> Maybe [Type]
-> Q (Cxt, Type)
buildTypeInstance tyConName jc dataCxt tvbs Nothing =
let varTys :: [Type]
varTys = map tvbToType tvbs
in buildTypeInstanceFromTys tyConName jc dataCxt varTys False
buildTypeInstance dataFamName jc dataCxt tvbs (Just instTysAndKinds) = do
#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)
let instTys :: [Type]
instTys = zipWith stealKindForType tvbs instTysAndKinds
#else
let kindVarNames :: [Name]
kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs
numKindVars :: Int
numKindVars = length kindVarNames
givenKinds, givenKinds' :: [Kind]
givenTys :: [Type]
(givenKinds, givenTys) = splitAt numKindVars instTysAndKinds
givenKinds' = map sanitizeStars givenKinds
sanitizeStars :: Kind -> Kind
sanitizeStars = go
where
go :: Kind -> Kind
go (AppT t1 t2) = AppT (go t1) (go t2)
go (SigT t k) = SigT (go t) (go k)
go (ConT n) | n == starKindName = StarT
go t = t
starKindName :: Name
starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"
xTypeNames <- newNameList "tExtra" (length tvbs length givenTys)
let xTys :: [Type]
xTys = map VarT xTypeNames
substNamesWithKinds :: [(Name, Kind)] -> Type -> Type
substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks
instTys :: [Type]
instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))
$ zipWith stealKindForType tvbs (givenTys ++ xTys)
#endif
buildTypeInstanceFromTys dataFamName jc dataCxt instTys True
buildTypeInstanceFromTys :: Name
-> JSONClass
-> Cxt
-> [Type]
-> Bool
-> Q (Cxt, Type)
buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
varTysExp <- mapM expandSyn varTysOrig
let remainingLength :: Int
remainingLength = length varTysOrig arityInt jc
droppedTysExp :: [Type]
droppedTysExp = drop remainingLength varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = map canRealizeKindStar droppedTysExp
when (remainingLength < 0 || elem NotKindStar droppedStarKindStati) $
derivingKindError jc tyConName
let droppedKindVarNames :: [Name]
droppedKindVarNames = catKindVarNames droppedStarKindStati
varTysExpSubst :: [Type]
varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp
remainingTysExpSubst, droppedTysExpSubst :: [Type]
(remainingTysExpSubst, droppedTysExpSubst) =
splitAt remainingLength varTysExpSubst
droppedTyVarNames :: [Name]
droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst
unless (all hasKindStar droppedTysExpSubst) $
derivingKindError jc tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
(preds, kvNames) = unzip $ map (deriveConstraint jc) remainingTysExpSubst
kvNames' = concat kvNames
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' =
map (substNamesWithKindStar kvNames') remainingTysExpSubst
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst =
map (substNamesWithKindStar (union droppedKindVarNames kvNames'))
$ take remainingLength varTysOrig
remainingTysOrigSubst' :: [Type]
remainingTysOrigSubst' =
if isDataFamily
then remainingTysOrigSubst
else map unSigT remainingTysOrigSubst
instanceCxt :: Cxt
instanceCxt = catMaybes preds
instanceType :: Type
instanceType = AppT (ConT $ jsonClassName jc)
$ applyTyCon tyConName remainingTysOrigSubst'
when (any (`predMentionsName` droppedTyVarNames) dataCxt) $
datatypeContextError tyConName instanceType
unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $
etaReductionError instanceType
return (instanceCxt, instanceType)
deriveConstraint :: JSONClass -> Type -> (Maybe Pred, [Name])
deriveConstraint jc t
| not (isTyVar t) = (Nothing, [])
| hasKindStar t = (Just (applyCon (jcConstraint Arity0) tName), [])
| otherwise = case hasKindVarChain 1 t of
Just ns | jcArity >= Arity1
-> (Just (applyCon (jcConstraint Arity1) tName), ns)
_ -> case hasKindVarChain 2 t of
Just ns | jcArity == Arity2
-> (Just (applyCon (jcConstraint Arity2) tName), ns)
_ -> (Nothing, [])
where
tName :: Name
tName = varTToName t
jcArity :: Arity
jcArity = arity jc
jcConstraint :: Arity -> Name
jcConstraint = jsonClassName . JSONClass (direction jc)
reifyConTys :: JSONClass
-> [(Name, Name)]
-> Name
-> Q ([Type], TyVarMap)
reifyConTys jc tpjs conName = do
info <- reify conName
(ctxt, uncTy) <- case info of
DataConI _ ty _
#if !(MIN_VERSION_template_haskell(2,11,0))
_
#endif
-> fmap uncurryTy (expandSyn ty)
_ -> error "Must be a data constructor"
let (argTys, [resTy]) = NE.splitAt (NE.length uncTy 1) uncTy
unapResTy = unapplyTy resTy
jArity = arityInt jc
mbTvNames = map varTToNameMaybe $
NE.drop (NE.length unapResTy jArity) unapResTy
tvMap = M.fromList
. catMaybes
$ zipWith (\mbTvName tpj ->
fmap (\tvName -> (tvName, tpj)) mbTvName)
mbTvNames tpjs
if (any (`predMentionsName` M.keys tvMap) ctxt
|| M.size tvMap < jArity)
&& not (allowExQuant jc)
then existentialContextError conName
else return (argTys, tvMap)
type TyVarMap = Map Name (Name, Name)
stealKindForType :: TyVarBndr -> Type -> Type
stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)
stealKindForType _ t = t
tvbKind :: TyVarBndr -> Kind
#if MIN_VERSION_template_haskell(2,8,0)
tvbKind (PlainTV _ ) = StarT
#else
tvbKind (PlainTV _ ) = StarK
#endif
tvbKind (KindedTV _ k) = k
tvbToType :: TyVarBndr -> Type
tvbToType (PlainTV n) = VarT n
tvbToType (KindedTV n k) = SigT (VarT n) k
hasKindStar :: Type -> Bool
hasKindStar VarT{} = True
#if MIN_VERSION_template_haskell(2,8,0)
hasKindStar (SigT _ StarT) = True
#else
hasKindStar (SigT _ StarK) = True
#endif
hasKindStar _ = False
isStarOrVar :: Kind -> Bool
#if MIN_VERSION_template_haskell(2,8,0)
isStarOrVar StarT = True
isStarOrVar VarT{} = True
#else
isStarOrVar StarK = True
#endif
isStarOrVar _ = False
newNameList :: String -> Int -> Q [Name]
newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]
tyVarNamesOfType :: Type -> [Name]
tyVarNamesOfType = go
where
go :: Type -> [Name]
go (AppT t1 t2) = go t1 ++ go t2
go (SigT t _k) = go t
#if MIN_VERSION_template_haskell(2,8,0)
++ go _k
#endif
go (VarT n) = [n]
go _ = []
tyVarNamesOfKind :: Kind -> [Name]
#if MIN_VERSION_template_haskell(2,8,0)
tyVarNamesOfKind = tyVarNamesOfType
#else
tyVarNamesOfKind _ = []
#endif
hasKindVarChain :: Int -> Type -> Maybe [Name]
hasKindVarChain kindArrows t =
let uk = uncurryKind (tyKind t)
in if (NE.length uk 1 == kindArrows) && F.all isStarOrVar uk
then Just (concatMap tyVarNamesOfKind uk)
else Nothing
tyKind :: Type -> Kind
tyKind (SigT _ k) = k
tyKind _ = starK
varTToNameMaybe :: Type -> Maybe Name
varTToNameMaybe (VarT n) = Just n
varTToNameMaybe (SigT t _) = varTToNameMaybe t
varTToNameMaybe _ = Nothing
varTToName :: Type -> Name
varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe
getConName :: Con -> Name
getConName (NormalC name _) = name
getConName (RecC name _) = name
getConName (InfixC _ name _) = name
getConName (ForallC _ _ con) = getConName con
#if MIN_VERSION_template_haskell(2,11,0)
getConName (GadtC names _ _) = head names
getConName (RecGadtC names _ _) = head names
#endif
interleave :: [a] -> [a] -> [a]
interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
interleave _ _ = []
applyTyCon :: Name -> [Type] -> Type
applyTyCon = foldl' AppT . ConT
isTyVar :: Type -> Bool
isTyVar (VarT _) = True
isTyVar (SigT t _) = isTyVar t
isTyVar _ = False
isTyFamily :: Type -> Q Bool
isTyFamily (ConT n) = do
info <- reify n
return $ case info of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI OpenTypeFamilyD{} _ -> True
#else
FamilyI (FamilyD TypeFam _ _ _) _ -> True
#endif
#if MIN_VERSION_template_haskell(2,9,0)
FamilyI ClosedTypeFamilyD{} _ -> True
#endif
_ -> False
isTyFamily _ = return False
unSigT :: Type -> Type
unSigT (SigT t _) = t
unSigT t = t
allDistinct :: Ord a => [a] -> Bool
allDistinct = allDistinct' Set.empty
where
allDistinct' :: Ord a => Set a -> [a] -> Bool
allDistinct' uniqs (x:xs)
| x `Set.member` uniqs = False
| otherwise = allDistinct' (Set.insert x uniqs) xs
allDistinct' _ _ = True
mentionsName :: Type -> [Name] -> Bool
mentionsName = go
where
go :: Type -> [Name] -> Bool
go (AppT t1 t2) names = go t1 names || go t2 names
go (SigT t _k) names = go t names
#if MIN_VERSION_template_haskell(2,8,0)
|| go _k names
#endif
go (VarT n) names = n `elem` names
go _ _ = False
predMentionsName :: Pred -> [Name] -> Bool
#if MIN_VERSION_template_haskell(2,10,0)
predMentionsName = mentionsName
#else
predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys
predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names
#endif
unapplyTy :: Type -> NonEmpty Type
unapplyTy = NE.reverse . go
where
go :: Type -> NonEmpty Type
go (AppT t1 t2) = t2 <| go t1
go (SigT t _) = go t
go (ForallT _ _ t) = go t
go t = t :| []
uncurryTy :: Type -> (Cxt, NonEmpty Type)
uncurryTy (AppT (AppT ArrowT t1) t2) =
let (ctxt, tys) = uncurryTy t2
in (ctxt, t1 <| tys)
uncurryTy (SigT t _) = uncurryTy t
uncurryTy (ForallT _ ctxt t) =
let (ctxt', tys) = uncurryTy t
in (ctxt ++ ctxt', tys)
uncurryTy t = ([], t :| [])
uncurryKind :: Kind -> NonEmpty Kind
#if MIN_VERSION_template_haskell(2,8,0)
uncurryKind = snd . uncurryTy
#else
uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2
uncurryKind k = k :| []
#endif
createKindChain :: Int -> Kind
createKindChain = go starK
where
go :: Kind -> Int -> Kind
go k !0 = k
#if MIN_VERSION_template_haskell(2,8,0)
go k !n = go (AppT (AppT ArrowT StarT) k) (n 1)
#else
go k !n = go (ArrowK StarK k) (n 1)
#endif
conNameExp :: Options -> Con -> Q Exp
conNameExp opts = litE
. stringL
. constructorTagModifier opts
. nameBase
. getConName
fieldLabelExp :: Options
-> Name
-> Q Exp
fieldLabelExp opts = litE . stringL . fieldLabelModifier opts . nameBase
valueConName :: Value -> String
valueConName (Object _) = "Object"
valueConName (Array _) = "Array"
valueConName (String _) = "String"
valueConName (Number _) = "Number"
valueConName (Bool _) = "Boolean"
valueConName Null = "Null"
applyCon :: Name -> Name -> Pred
applyCon con t =
#if MIN_VERSION_template_haskell(2,10,0)
AppT (ConT con) (VarT t)
#else
ClassP con [VarT t]
#endif
canEtaReduce :: [Type] -> [Type] -> Bool
canEtaReduce remaining dropped =
all isTyVar dropped
&& allDistinct droppedNames
&& not (any (`mentionsName` droppedNames) remaining)
where
droppedNames :: [Name]
droppedNames = map varTToName dropped
expandSyn :: Type -> Q Type
expandSyn (ForallT tvs ctx t) = ForallT tvs ctx <$> expandSyn t
expandSyn t@AppT{} = expandSynApp t []
expandSyn t@ConT{} = expandSynApp t []
expandSyn (SigT t k) = do t' <- expandSyn t
k' <- expandSynKind k
return (SigT t' k')
expandSyn t = return t
expandSynKind :: Kind -> Q Kind
#if MIN_VERSION_template_haskell(2,8,0)
expandSynKind = expandSyn
#else
expandSynKind = return
#endif
expandSynApp :: Type -> [Type] -> Q Type
expandSynApp (AppT t1 t2) ts = do
t2' <- expandSyn t2
expandSynApp t1 (t2':ts)
expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts
expandSynApp t@(ConT n) ts = do
info <- reify n
case info of
TyConI (TySynD _ tvs rhs) ->
let (ts', ts'') = splitAt (length tvs) ts
subs = mkSubst tvs ts'
rhs' = substType subs rhs
in expandSynApp rhs' ts''
_ -> return $ foldl' AppT t ts
expandSynApp t ts = do
t' <- expandSyn t
return $ foldl' AppT t' ts
type TypeSubst = Map Name Type
type KindSubst = Map Name Kind
mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst
mkSubst vs ts =
let vs' = map un vs
un (PlainTV v) = v
un (KindedTV v _) = v
in M.fromList $ zip vs' ts
substType :: TypeSubst -> Type -> Type
substType subs (ForallT v c t) = ForallT v c $ substType subs t
substType subs t@(VarT n) = M.findWithDefault t n subs
substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)
substType subs (SigT t k) = SigT (substType subs t)
#if MIN_VERSION_template_haskell(2,8,0)
(substType subs k)
#else
k
#endif
substType _ t = t
substKind :: KindSubst -> Type -> Type
#if MIN_VERSION_template_haskell(2,8,0)
substKind = substType
#else
substKind _ t = t
#endif
substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind n k = substKind (M.singleton n k)
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns
derivingKindError :: JSONClass -> Name -> Q a
derivingKindError jc tyConName = fail
. showString "Cannot derive well-kinded instance of form ‘"
. showString className
. showChar ' '
. showParen True
( showString (nameBase tyConName)
. showString " ..."
)
. showString "‘\n\tClass "
. showString className
. showString " expects an argument of kind "
. showString (pprint . createKindChain $ arityInt jc)
$ ""
where
className :: String
className = nameBase $ jsonClassName jc
etaReductionError :: Type -> Q a
etaReductionError instanceType = fail $
"Cannot eta-reduce to an instance of form \n\tinstance (...) => "
++ pprint instanceType
datatypeContextError :: Name -> Type -> Q a
datatypeContextError dataName instanceType = fail
. showString "Can't make a derived instance of ‘"
. showString (pprint instanceType)
. showString "‘:\n\tData type ‘"
. showString (nameBase dataName)
. showString "‘ must not have a class context involving the last type argument(s)"
$ ""
outOfPlaceTyVarError :: JSONClass -> Name -> a
outOfPlaceTyVarError jc conName = error
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must only use its last "
. shows n
. showString " type variable(s) within the last "
. shows n
. showString " argument(s) of a data type"
$ ""
where
n :: Int
n = arityInt jc
existentialContextError :: Name -> a
existentialContextError conName = error
. showString "Constructor ‘"
. showString (nameBase conName)
. showString "‘ must be truly polymorphic in the last argument(s) of the data type"
$ ""
data Arity = Arity0 | Arity1 | Arity2
deriving (Enum, Eq, Ord)
data Direction = To | From
data JSONFun = ToJSON | ToEncoding | ParseJSON
data JSONClass = JSONClass { direction :: Direction, arity :: Arity }
toJSONClass, toJSON1Class, toJSON2Class,
fromJSONClass, fromJSON1Class, fromJSON2Class :: JSONClass
toJSONClass = JSONClass To Arity0
toJSON1Class = JSONClass To Arity1
toJSON2Class = JSONClass To Arity2
fromJSONClass = JSONClass From Arity0
fromJSON1Class = JSONClass From Arity1
fromJSON2Class = JSONClass From Arity2
jsonClassName :: JSONClass -> Name
jsonClassName (JSONClass To Arity0) = ''ToJSON
jsonClassName (JSONClass To Arity1) = ''ToJSON1
jsonClassName (JSONClass To Arity2) = ''ToJSON2
jsonClassName (JSONClass From Arity0) = ''FromJSON
jsonClassName (JSONClass From Arity1) = ''FromJSON1
jsonClassName (JSONClass From Arity2) = ''FromJSON2
jsonFunValName :: JSONFun -> Arity -> Name
jsonFunValName ToJSON Arity0 = 'toJSON
jsonFunValName ToJSON Arity1 = 'liftToJSON
jsonFunValName ToJSON Arity2 = 'liftToJSON2
jsonFunValName ToEncoding Arity0 = 'toEncoding
jsonFunValName ToEncoding Arity1 = 'liftToEncoding
jsonFunValName ToEncoding Arity2 = 'liftToEncoding2
jsonFunValName ParseJSON Arity0 = 'parseJSON
jsonFunValName ParseJSON Arity1 = 'liftParseJSON
jsonFunValName ParseJSON Arity2 = 'liftParseJSON2
jsonFunListName :: JSONFun -> Arity -> Name
jsonFunListName ToJSON Arity0 = 'toJSONList
jsonFunListName ToJSON Arity1 = 'liftToJSONList
jsonFunListName ToJSON Arity2 = 'liftToJSONList2
jsonFunListName ToEncoding Arity0 = 'toEncodingList
jsonFunListName ToEncoding Arity1 = 'liftToEncodingList
jsonFunListName ToEncoding Arity2 = 'liftToEncodingList2
jsonFunListName ParseJSON Arity0 = 'parseJSONList
jsonFunListName ParseJSON Arity1 = 'liftParseJSONList
jsonFunListName ParseJSON Arity2 = 'liftParseJSONList2
jsonFunValOrListName :: Bool
-> JSONFun -> Arity -> Name
jsonFunValOrListName False = jsonFunValName
jsonFunValOrListName True = jsonFunListName
arityInt :: JSONClass -> Int
arityInt = fromEnum . arity
allowExQuant :: JSONClass -> Bool
allowExQuant (JSONClass To _) = True
allowExQuant _ = False
data StarKindStatus = NotKindStar
| KindStar
| IsKindVar Name
deriving Eq
canRealizeKindStar :: Type -> StarKindStatus
canRealizeKindStar t
| hasKindStar t = KindStar
| otherwise = case t of
#if MIN_VERSION_template_haskell(2,8,0)
SigT _ (VarT k) -> IsKindVar k
#endif
_ -> NotKindStar
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar n) = Just n
starKindStatusToName _ = Nothing
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = mapMaybe starKindStatusToName