{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 800
{-# LANGUAGE TemplateHaskellQuotes #-}
#else
{-# LANGUAGE TemplateHaskell #-}
#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.Compat hiding (fail)
import Prelude (fail)
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 ((<?>), JSONPathElement(Key))
import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
import Data.Aeson.Types.ToJSON (fromPairs, pair)
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 (foldl', genericLength, intercalate, partition, union)
import Data.List.NonEmpty ((<|), NonEmpty((:|)))
import Data.Map (Map)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import qualified Data.Monoid as Monoid
import Data.Set (Set)
import Language.Haskell.TH hiding (Arity)
import Language.Haskell.TH.Datatype
#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.Encoding.Internal as E
import qualified Data.Foldable as F (all)
import qualified Data.HashMap.Strict as H (difference, fromList, keys, lookup, toList)
import qualified Data.List.NonEmpty as NE (length, reverse)
import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
import qualified Data.Semigroup as Semigroup (Option(..))
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, empty)
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 Value jc)
, (ToEncoding, \jc _ -> consToValue Encoding 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 Value 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 _ -> consToValue Encoding jc)
consToValue :: ToJSONFun
-> JSONClass
-> Options
-> [Type]
-> [ConstructorInfo]
-> Q Exp
consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
++ "Not a single constructor given!"
consToValue target jc opts instTys cons = do
value <- newName "value"
tjs <- newNameList "_tj" $ arityInt jc
tjls <- newNameList "_tjl" $ arityInt jc
let zippedTJs = zip tjs tjls
interleavedTJs = interleave tjs tjls
lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys
tvMap = M.fromList $ zip lastTyVars zippedTJs
lamE (map varP $ interleavedTJs ++ [value]) $
caseE (varE value) (matches tvMap)
where
matches tvMap = case cons of
[con] | not (tagSingleConstructors opts) -> [argsToValue target jc tvMap opts False con]
_ | allNullaryToStringTag opts && all isNullary cons ->
[ match (conP conName []) (normalB $ conStr target opts conName) []
| con <- cons
, let conName = constructorName con
]
| otherwise -> [argsToValue target jc tvMap opts True con | con <- cons]
conStr :: ToJSONFun -> Options -> Name -> Q Exp
conStr Value opts = appE [|String|] . conTxt opts
conStr Encoding opts = appE [|E.text|] . conTxt opts
conTxt :: Options -> Name -> Q Exp
conTxt opts = appE [|T.pack|] . stringE . conString opts
conString :: Options -> Name -> String
conString opts = constructorTagModifier opts . nameBase
isNullary :: ConstructorInfo -> Bool
isNullary ConstructorInfo { constructorVariant = NormalConstructor
, constructorFields = tys } = null tys
isNullary _ = False
opaqueSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
opaqueSumToValue target opts multiCons nullary conName value =
sumToValue target opts multiCons nullary conName
value
pairs
where
pairs contentsFieldName = pairE contentsFieldName value
recordSumToValue :: ToJSONFun -> Options -> Bool -> Bool -> Name -> ExpQ -> ExpQ
recordSumToValue target opts multiCons nullary conName pairs =
sumToValue target opts multiCons nullary conName
(fromPairsE pairs)
(const pairs)
sumToValue
:: ToJSONFun
-> Options
-> Bool
-> Bool
-> Name
-> ExpQ
-> (String -> ExpQ)
-> ExpQ
sumToValue target opts multiCons nullary conName value pairs
| multiCons =
case sumEncoding opts of
TwoElemArray ->
array target [conStr target opts conName, value]
TaggedObject{tagFieldName, contentsFieldName} ->
let tag = pairE tagFieldName (conStr target opts conName)
content = pairs contentsFieldName
in fromPairsE $
if nullary then tag else infixApp tag [|(Monoid.<>)|] content
ObjectWithSingleField ->
objectE [(conString opts conName, value)]
UntaggedValue | nullary -> conStr target opts conName
UntaggedValue -> value
| otherwise = value
argsToValue :: ToJSONFun -> JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
argsToValue target jc tvMap opts multiCons
ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = argTys } = do
argTys' <- mapM resolveTypeSynonyms argTys
let len = length argTys'
args <- newNameList "arg" len
let js = case [ dispatchToJSON target jc conName tvMap argTy
`appE` varE arg
| (arg, argTy) <- zip args argTys'
] of
[e] -> e
es -> array target es
match (conP conName $ map varP args)
(normalB $ opaqueSumToValue target opts multiCons (null argTys') conName js)
[]
argsToValue target jc tvMap opts multiCons
info@ConstructorInfo { constructorName = conName
, constructorVariant = RecordConstructor fields
, constructorFields = argTys } =
case (unwrapUnaryRecords opts, not multiCons, argTys) of
(True,True,[_]) -> argsToValue target jc tvMap opts multiCons
(info{constructorVariant = NormalConstructor})
_ -> do
argTys' <- mapM resolveTypeSynonyms argTys
args <- newNameList "arg" $ length argTys'
let pairs | omitNothingFields opts = infixApp maybeFields
[|(Monoid.<>)|]
restFields
| otherwise = mconcatE (map pureToPair argCons)
argCons = zip3 (map varE args) argTys' fields
maybeFields = mconcatE (map maybeToPair maybes)
restFields = mconcatE (map pureToPair rest)
(maybes0, rest0) = partition isMaybe argCons
(options, rest) = partition isOption rest0
maybes = maybes0 ++ map optionToMaybe options
maybeToPair = toPairLifted True
pureToPair = toPairLifted False
toPairLifted lifted (arg, argTy, field) =
let toValue = dispatchToJSON target jc conName tvMap argTy
fieldName = fieldLabel opts field
e arg' = pairE fieldName (toValue `appE` arg')
in if lifted
then do
x <- newName "x"
[|maybe mempty|] `appE` lam1E (varP x) (e (varE x)) `appE` arg
else e arg
match (conP conName $ map varP args)
(normalB $ recordSumToValue target opts multiCons (null argTys) conName pairs)
[]
argsToValue target jc tvMap opts multiCons
ConstructorInfo { constructorName = conName
, constructorVariant = InfixConstructor
, constructorFields = argTys } = do
[alTy, arTy] <- mapM resolveTypeSynonyms argTys
al <- newName "argL"
ar <- newName "argR"
match (infixP (varP al) conName (varP ar))
( normalB
$ opaqueSumToValue target opts multiCons False conName
$ array target
[ dispatchToJSON target jc conName tvMap aTy
`appE` varE a
| (a, aTy) <- [(al,alTy), (ar,arTy)]
]
)
[]
isMaybe :: (a, Type, b) -> Bool
isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe
isMaybe _ = False
isOption :: (a, Type, b) -> Bool
isOption (_, AppT (ConT t) _, _) = t == ''Semigroup.Option
isOption _ = False
optionToMaybe :: (ExpQ, b, c) -> (ExpQ, b, c)
optionToMaybe (a, b, c) = ([|Semigroup.getOption|] `appE` a, b, c)
(<^>) :: ExpQ -> ExpQ -> ExpQ
(<^>) a b = infixApp a [|(E.><)|] b
infixr 6 <^>
(<%>) :: ExpQ -> ExpQ -> ExpQ
(<%>) a b = a <^> [|E.comma|] <^> b
infixr 4 <%>
array :: ToJSONFun -> [ExpQ] -> ExpQ
array Encoding [] = [|E.emptyArray_|]
array Value [] = [|Array V.empty|]
array Encoding es = [|E.wrapArray|] `appE` foldr1 (<%>) es
array Value es = do
mv <- newName "mv"
let newMV = bindS (varP mv)
([|VM.unsafeNew|] `appE`
litE (integerL $ fromIntegral (length es)))
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
[|Array|] `appE`
(varE 'V.create `appE`
doE (newMV:stmts++[ret]))
objectE :: [(String, ExpQ)] -> ExpQ
objectE = fromPairsE . mconcatE . fmap (uncurry pairE)
mconcatE :: [ExpQ] -> ExpQ
mconcatE [] = [|Monoid.mempty|]
mconcatE [x] = x
mconcatE (x : xs) = infixApp x [|(Monoid.<>)|] (mconcatE xs)
fromPairsE :: ExpQ -> ExpQ
fromPairsE = ([|fromPairs|] `appE`)
pairE :: String -> ExpQ -> ExpQ
pairE k v = [|pair k|] `appE` v
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
-> [Type]
-> [ConstructorInfo]
-> Q Exp
consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
++ "Not a single constructor given!"
consFromJSON jc tName opts instTys cons = do
value <- newName "value"
pjs <- newNameList "_pj" $ arityInt jc
pjls <- newNameList "_pjl" $ arityInt jc
let zippedPJs = zip pjs pjls
interleavedPJs = interleave pjs pjls
lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys
tvMap = M.fromList $ zip lastTyVars zippedPJs
lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap
where
checkExi tvMap con = checkExistentialContext jc tvMap
(constructorContext con)
(constructorName con)
lamExpr value tvMap = case cons of
[con]
| not (tagSingleConstructors opts)
-> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)
_ | sumEncoding opts == UntaggedValue
-> parseUntaggedValue tvMap cons value
| otherwise
-> caseE (varE value) $
if allNullaryToStringTag opts && all isNullary cons
then allNullaryMatches
else mixedMatches tvMap
allNullaryMatches =
[ do txt <- newName "txt"
match (conP 'String [varP txt])
(guardedB $
[ liftM2 (,) (normalG $
infixApp (varE txt)
[|(==)|]
(conTxt opts conName)
)
([|pure|] `appE` conE conName)
| con <- cons
, let conName = constructorName 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 tvMap =
case sumEncoding opts of
TaggedObject {tagFieldName, contentsFieldName} ->
parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
UntaggedValue -> error "UntaggedValue: Should be handled already"
ObjectWithSingleField ->
parseObject $ parseObjectWithSingleField tvMap
TwoElemArray ->
[ do arr <- newName "array"
match (conP 'Array [varP arr])
(guardedB
[ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
[|(==)|]
(litE $ integerL 2))
(parse2ElemArray tvMap 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 tvMap typFieldName valFieldName obj = do
conKey <- newName "conKey"
doE [ bindS (varP conKey)
(infixApp (varE obj)
[|(.:)|]
([|T.pack|] `appE` stringE typFieldName))
, noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
]
parseUntaggedValue tvMap cons' conVal =
foldr1 (\e e' -> infixApp e [|(<|>)|] e')
(map (\x -> parseValue tvMap x conVal) cons')
parseValue _tvMap
ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = [] }
conVal = do
str <- newName "str"
caseE (varE conVal)
[ match (conP 'String [varP str])
(guardedB
[ liftM2 (,) (normalG $ infixApp (varE str) [|(==)|] (conTxt opts conName)
)
([|pure|] `appE` conE conName)
]
)
[]
, matchFailed tName conName "String"
]
parseValue tvMap con conVal =
checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)
parse2ElemArray tvMap 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 tvMap
txt
(Right conVal)
'conNotFoundFail2ElemArray
)
[]
, do other <- newName "other"
match (varP other)
( normalB
$ [|firstElemNoStringFail|]
`appE` litE (stringL $ show tName)
`appE` ([|valueConName|] `appE` varE other)
)
[]
]
)
parseObjectWithSingleField tvMap obj = do
conKey <- newName "conKey"
conVal <- newName "conVal"
caseE ([e|H.toList|] `appE` varE obj)
[ match (listP [tupP [varP conKey, varP conVal]])
(normalB $ parseContents tvMap 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 tvMap conKey contents errorFun =
caseE (varE conKey)
[ match wildP
( guardedB $
[ do g <- normalG $ infixApp (varE conKey)
[|(==)|]
([|T.pack|] `appE`
conNameExp opts con)
e <- checkExi tvMap con $
parseArgs jc tvMap 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
. constructorName
) 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
-> [Name]
-> Name
-> Bool
-> ExpQ
parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
(if rejectUnknownFields opts
then infixApp checkUnknownRecords [|(>>)|]
else id) $
foldl' (\a b -> infixApp a [|(<*>)|] b)
(infixApp (conE conName) [|(<$>)|] x)
xs
where
tagFieldNameAppender =
if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id
knownFields = appE [|H.fromList|] $ listE $
map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $
tagFieldNameAppender $ map (fieldLabel opts) fields
checkUnknownRecords =
caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)
[ match (listP []) (normalB [|return ()|]) []
, newName "unknownFields" >>=
\unknownFields -> match (varP unknownFields)
(normalB $ appE [|fail|] $ infixApp
(litE (stringL "Unknown fields: "))
[|(++)|]
(appE [|show|] (varE unknownFields)))
[]
]
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` stringE (fieldLabel opts field)
)
| (field, argTy) <- zip fields 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
-> TyVarMap
-> Name
-> Options
-> ConstructorInfo
-> Either (String, Name) Name
-> Q Exp
parseArgs _ _ _ _
ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = [] }
(Left _) =
[|pure|] `appE` conE conName
parseArgs _ _ tName _
ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = [] }
(Right valName) =
caseE (varE valName) $ parseNullaryMatches tName conName
parseArgs jc tvMap _ _
ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = [argTy] }
contents = do
argTy' <- resolveTypeSynonyms argTy
matchCases contents $ parseUnaryMatches jc tvMap argTy' conName
parseArgs jc tvMap tName _
ConstructorInfo { constructorName = conName
, constructorVariant = NormalConstructor
, constructorFields = argTys }
contents = do
argTys' <- mapM resolveTypeSynonyms argTys
let len = genericLength argTys'
matchCases contents $ parseProduct jc tvMap argTys' tName conName len
parseArgs jc tvMap tName opts
ConstructorInfo { constructorName = conName
, constructorVariant = RecordConstructor fields
, constructorFields = argTys }
(Left (_, obj)) = do
argTys' <- mapM resolveTypeSynonyms argTys
parseRecord jc tvMap argTys' opts tName conName fields obj True
parseArgs jc tvMap tName opts
info@ConstructorInfo { constructorName = conName
, constructorVariant = RecordConstructor fields
, constructorFields = argTys }
(Right valName) =
case (unwrapUnaryRecords opts,argTys) of
(True,[_])-> parseArgs jc tvMap tName opts
(info{constructorVariant = NormalConstructor})
(Right valName)
_ -> do
obj <- newName "recObj"
argTys' <- mapM resolveTypeSynonyms argTys
caseE (varE valName)
[ match (conP 'Object [varP obj]) (normalB $
parseRecord jc tvMap argTys' opts tName conName fields obj False) []
, matchFailed tName conName "Object"
]
parseArgs jc tvMap tName _
ConstructorInfo { constructorName = conName
, constructorVariant = InfixConstructor
, constructorFields = argTys }
contents = do
argTys' <- mapM resolveTypeSynonyms argTys
matchCases contents $ parseProduct jc tvMap argTys' tName conName 2
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
instance INCOHERENT_ LookupField (Semigroup.Option a) where
lookupField pj tName rec obj key =
fmap Semigroup.Option
(lookupField (fmap Semigroup.getOption . pj) tName rec obj key)
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
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 -> [Type]
-> [ConstructorInfo] -> Q Exp)]
-> JSONClass
-> Options
-> Name
-> Q [Dec]
deriveJSONClass consFuns jc opts name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
#if MIN_VERSION_th_abstraction(0,3,0)
, datatypeInstTypes = instTys
#else
, datatypeVars = instTys
#endif
, datatypeVariant = variant
, datatypeCons = cons
} -> do
(instanceCxt, instanceType)
<- buildTypeInstance parentName jc ctxt instTys variant
(:[]) <$> instanceD (return instanceCxt)
(return instanceType)
(methodDecs parentName instTys cons)
where
methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
methodDecs parentName instTys cons = flip map consFuns $ \(jf, jfMaker) ->
funD (jsonFunValName jf (arity jc))
[ clause []
(normalB $ jfMaker jc parentName opts instTys cons)
[]
]
mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
-- ^ The function which derives the expression.
-> JSONClass
-- ^ Which class's method is being derived.
-> Options
-- ^ Encoding options.
-> Name
-- ^ Name of the encoded type.
-> Q Exp
mkFunCommon consFun jc opts name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
#if MIN_VERSION_th_abstraction(0,3,0)
, datatypeInstTypes = instTys
#else
, datatypeVars = instTys
#endif
, datatypeVariant = variant
, datatypeCons = cons
} -> do
-- We force buildTypeInstance here since it performs some checks for whether
-- or not the provided datatype's kind matches the derived method's
-- typeclass, and produces errors if it can't.
!_ <- buildTypeInstance parentName jc ctxt instTys variant
consFun jc parentName opts instTys cons
dispatchFunByType :: JSONClass
-> JSONFun
-> Name
-> TyVarMap
-> Bool -- True if we are using the function argument that works
-- on lists (e.g., [a] -> Value). False is we are using
-- the function argument that works on single values
-- (e.g., a -> Value).
-> 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 <- isInTypeFamilyApp tyVarNames tyCon tyArgs
if any (`mentionsName` tyVarNames) lhsArgs || itf
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
:: ToJSONFun -> JSONClass -> Name -> TyVarMap -> Type -> Q Exp
dispatchToJSON target jc n tvMap =
dispatchFunByType jc (targetToJSONFun target) n tvMap False
dispatchParseJSON
:: JSONClass -> Name -> TyVarMap -> Type -> Q Exp
dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False
--------------------------------------------------------------------------------
-- Utility functions
--------------------------------------------------------------------------------
-- For the given Types, generate an instance context and head.
buildTypeInstance :: Name
-- ^ The type constructor or data family name
-> JSONClass
-- ^ The typeclass to derive
-> Cxt
-- ^ The datatype context
-> [Type]
-- ^ The types to instantiate the instance with
-> DatatypeVariant
-- ^ Are we dealing with a data family instance or not
-> Q (Cxt, Type)
buildTypeInstance tyConName jc dataCxt varTysOrig variant = do
-- Make sure to expand through type/kind synonyms! Otherwise, the
-- eta-reduction check might get tripped up over type variables in a
-- synonym that are actually dropped.
-- (See GHC Trac #11416 for a scenario where this actually happened.)
varTysExp <- mapM resolveTypeSynonyms varTysOrig
let remainingLength :: Int
remainingLength = length varTysOrig - arityInt jc
droppedTysExp :: [Type]
droppedTysExp = drop remainingLength varTysExp
droppedStarKindStati :: [StarKindStatus]
droppedStarKindStati = map canRealizeKindStar droppedTysExp
-- Check there are enough types to drop and that all of them are either of
-- kind * or kind k (for some kind variable k). If not, throw an error.
when (remainingLength < 0 || elem NotKindStar droppedStarKindStati) $
derivingKindError jc tyConName
let droppedKindVarNames :: [Name]
droppedKindVarNames = catKindVarNames droppedStarKindStati
-- Substitute kind * for any dropped kind variables
varTysExpSubst :: [Type]
varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp
remainingTysExpSubst, droppedTysExpSubst :: [Type]
(remainingTysExpSubst, droppedTysExpSubst) =
splitAt remainingLength varTysExpSubst
-- All of the type variables mentioned in the dropped types
-- (post-synonym expansion)
droppedTyVarNames :: [Name]
droppedTyVarNames = freeVariables droppedTysExpSubst
-- If any of the dropped types were polykinded, ensure that they are of kind *
-- after substituting * for the dropped kind variables. If not, throw an error.
unless (all hasKindStar droppedTysExpSubst) $
derivingKindError jc tyConName
let preds :: [Maybe Pred]
kvNames :: [[Name]]
kvNames' :: [Name]
-- Derive instance constraints (and any kind variables which are specialized
-- to * in those constraints)
(preds, kvNames) = unzip $ map (deriveConstraint jc) remainingTysExpSubst
kvNames' = concat kvNames
-- Substitute the kind variables specialized in the constraints with *
remainingTysExpSubst' :: [Type]
remainingTysExpSubst' =
map (substNamesWithKindStar kvNames') remainingTysExpSubst
-- We now substitute all of the specialized-to-* kind variable names with
-- *, but in the original types, not the synonym-expanded types. The reason
-- we do this is a superficial one: we want the derived instance to resemble
-- the datatype written in source code as closely as possible. For example,
-- for the following data family instance:
--
-- data family Fam a
-- newtype instance Fam String = Fam String
--
-- We'd want to generate the instance:
--
-- instance C (Fam String)
--
-- Not:
--
-- instance C (Fam [Char])
remainingTysOrigSubst :: [Type]
remainingTysOrigSubst =
map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))
$ take remainingLength varTysOrig
isDataFamily :: Bool
isDataFamily = case variant of
Datatype -> False
Newtype -> False
DataInstance -> True
NewtypeInstance -> True
remainingTysOrigSubst' :: [Type]
-- See Note [Kind signatures in derived instances] for an explanation
-- of the isDataFamily check.
remainingTysOrigSubst' =
if isDataFamily
then remainingTysOrigSubst
else map unSigT remainingTysOrigSubst
instanceCxt :: Cxt
instanceCxt = catMaybes preds
instanceType :: Type
instanceType = AppT (ConT $ jsonClassName jc)
$ applyTyCon tyConName remainingTysOrigSubst'
-- If the datatype context mentions any of the dropped type variables,
-- we can't derive an instance, so throw an error.
when (any (`predMentionsName` droppedTyVarNames) dataCxt) $
datatypeContextError tyConName instanceType
-- Also ensure the dropped types can be safely eta-reduced. Otherwise,
-- throw an error.
unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $
etaReductionError instanceType
return (instanceCxt, instanceType)
-- | Attempt to derive a constraint on a Type. If successful, return
-- Just the constraint and any kind variable names constrained to *.
-- Otherwise, return Nothing and the empty list.
--
-- See Note [Type inference in derived instances] for the heuristics used to
-- come up with constraints.
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)
{-
Note [Kind signatures in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is possible to put explicit kind signatures into the derived instances, e.g.,
instance C a => C (Data (f :: * -> *)) where ...
But it is preferable to avoid this if possible. If we come up with an incorrect
kind signature (which is entirely possible, since Template Haskell doesn't always
have the best track record with reifying kind signatures), then GHC will flat-out
reject the instance, which is quite unfortunate.
Plain old datatypes have the advantage that you can avoid using any kind signatures
at all in their instances. This is because a datatype declaration uses all type
variables, so the types that we use in a derived instance uniquely determine their
kinds. As long as we plug in the right types, the kind inferencer can do the rest
of the work. For this reason, we use unSigT to remove all kind signatures before
splicing in the instance context and head.
Data family instances are trickier, since a data family can have two instances that
are distinguished by kind alone, e.g.,
data family Fam (a :: k)
data instance Fam (a :: * -> *)
data instance Fam (a :: *)
If we dropped the kind signatures for C (Fam a), then GHC will have no way of
knowing which instance we are talking about. To avoid this scenario, we always
include explicit kind signatures in data family instances. There is a chance that
the inferred kind signatures will be incorrect, but if so, we can always fall back
on the mk- functions.
Note [Type inference in derived instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Type inference is can be tricky to get right, and we want to avoid recreating the
entirety of GHC's type inferencer in Template Haskell. For this reason, we will
probably never come up with derived instance contexts that are as accurate as
GHC's. But that doesn't mean we can't do anything! There are a couple of simple
things we can do to make instance contexts that work for 80% of use cases:
1. If one of the last type parameters is polykinded, then its kind will be
specialized to * in the derived instance. We note what kind variable the type
parameter had and substitute it with * in the other types as well. For example,
imagine you had
data Data (a :: k) (b :: k)
Then you'd want to derived instance to be:
instance C (Data (a :: *))
Not:
instance C (Data (a :: k))
2. We naïvely come up with instance constraints using the following criteria:
(i) If there's a type parameter n of kind *, generate a ToJSON n/FromJSON n
constraint.
(ii) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind
variables), then generate a ToJSON1 n/FromJSON1 n constraint, and if
k1/k2 are kind variables, then substitute k1/k2 with * elsewhere in the
types. We must consider the case where they are kind variables because
you might have a scenario like this:
newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)
= Compose (f (g a))
Which would have a derived ToJSON1 instance of:
instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where ...
(iii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are
* or kind variables), then generate a ToJSON2 n/FromJSON2 n constraint
and perform kind substitution as in the other cases.
-}
checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name
-> Q a -> Q a
checkExistentialContext jc tvMap ctxt conName q =
if (any (`predMentionsName` M.keys tvMap) ctxt
|| M.size tvMap < arityInt jc)
&& not (allowExQuant jc)
then existentialContextError conName
else q
{-
Note [Matching functions with GADT type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When deriving ToJSON2, there is a tricky corner case to consider:
data Both a b where
BothCon :: x -> x -> Both x x
Which encoding functions should be applied to which arguments of BothCon?
We have a choice, since both the function of type (a -> Value) and of type
(b -> Value) can be applied to either argument. In such a scenario, the
second encoding function takes precedence over the first encoding function, so the
derived ToJSON2 instance would be something like:
instance ToJSON2 Both where
liftToJSON2 tj1 tj2 p (BothCon x1 x2) = Array $ create $ do
mv <- unsafeNew 2
unsafeWrite mv 0 (tj1 x1)
unsafeWrite mv 1 (tj2 x2)
return mv
This is not an arbitrary choice, as this definition ensures that
liftToJSON2 toJSON = liftToJSON for a derived ToJSON1 instance for
Both.
-}
-- A mapping of type variable Names to their encoding/decoding function Names.
-- For example, in a ToJSON2 declaration, a TyVarMap might look like
--
-- { a ~> (tj1, tjl1)
-- , b ~> (tj2, tjl2) }
--
-- where a and b are the last two type variables of the datatype, tj1 and tjl1 are
-- the function arguments of types (a -> Value) and ([a] -> Value), and tj2 and tjl2
-- are the function arguments of types (b -> Value) and ([b] -> Value).
type TyVarMap = Map Name (Name, Name)
-- | Returns True if a Type has kind *.
hasKindStar :: Type -> Bool
hasKindStar VarT{} = True
hasKindStar (SigT _ StarT) = True
hasKindStar _ = False
-- Returns True is a kind is equal to *, or if it is a kind variable.
isStarOrVar :: Kind -> Bool
isStarOrVar StarT = True
isStarOrVar VarT{} = True
isStarOrVar _ = False
-- Generate a list of fresh names with a common prefix, and numbered suffixes.
newNameList :: String -> Int -> Q [Name]
newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]
-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
-- kind variables.
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 freeVariables uk)
else Nothing
-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
tyKind :: Type -> Kind
tyKind (SigT _ k) = k
tyKind _ = starK
-- | Extract Just the Name from a type variable. If the argument Type is not a
-- type variable, return Nothing.
varTToNameMaybe :: Type -> Maybe Name
varTToNameMaybe (VarT n) = Just n
varTToNameMaybe (SigT t _) = varTToNameMaybe t
varTToNameMaybe _ = Nothing
-- | Extract the Name from a type variable. If the argument Type is not a
-- type variable, throw an error.
varTToName :: Type -> Name
varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe
interleave :: [a] -> [a] -> [a]
interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
interleave _ _ = []
-- | Fully applies a type constructor to its type variables.
applyTyCon :: Name -> [Type] -> Type
applyTyCon = foldl' AppT . ConT
-- | Is the given type a variable?
isTyVar :: Type -> Bool
isTyVar (VarT _) = True
isTyVar (SigT t _) = isTyVar t
isTyVar _ = False
-- | Detect if a Name in a list of provided Names occurs as an argument to some
-- type family. This makes an effort to exclude /oversaturated/ arguments to
-- type families. For instance, if one declared the following type family:
--
-- @
-- type family F a :: Type -> Type
-- @
--
-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,
-- but not @b@.
isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool
isInTypeFamilyApp names tyFun tyArgs =
case tyFun of
ConT tcName -> go tcName
_ -> return False
where
go :: Name -> Q Bool
go tcName = do
info <- reify tcName
case info of
#if MIN_VERSION_template_haskell(2,11,0)
FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _
-> withinFirstArgs bndrs
FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _
-> withinFirstArgs bndrs
#else
FamilyI (FamilyD TypeFam _ bndrs _) _
-> withinFirstArgs bndrs
FamilyI (ClosedTypeFamilyD _ bndrs _ _) _
-> withinFirstArgs bndrs
#endif
_ -> return False
where
withinFirstArgs :: [a] -> Q Bool
withinFirstArgs bndrs =
let firstArgs = take (length bndrs) tyArgs
argFVs = freeVariables firstArgs
in return $ any (`elem` argFVs) names
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
|| go _k names
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
uncurryKind = snd . uncurryTy
createKindChain :: Int -> Kind
createKindChain = go starK
where
go :: Kind -> Int -> Kind
go k 0 = k
go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)
conNameExp :: Options -> ConstructorInfo -> Q Exp
conNameExp opts = litE
. stringL
. constructorTagModifier opts
. nameBase
. constructorName
fieldLabel :: Options
-> Name
-> String
fieldLabel opts = 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
applySubstitutionKind :: Map Name Kind -> Type -> Type
applySubstitutionKind = applySubstitution
substNameWithKind :: Name -> Kind -> Type -> Type
substNameWithKind n k = applySubstitutionKind (M.singleton n k)
substNamesWithKindStar :: [Name] -> Type -> Type
substNamesWithKindStar ns t = foldr' (`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 ToJSONFun = Value | Encoding
targetToJSONFun :: ToJSONFun -> JSONFun
targetToJSONFun Value = ToJSON
targetToJSONFun Encoding = ToEncoding
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 = case t of
_ | hasKindStar t -> KindStar
SigT _ (VarT k) -> IsKindVar k
_ -> NotKindStar
starKindStatusToName :: StarKindStatus -> Maybe Name
starKindStatusToName (IsKindVar n) = Just n
starKindStatusToName _ = Nothing
catKindVarNames :: [StarKindStatus] -> [Name]
catKindVarNames = mapMaybe starKindStatusToName