@@ -130,7 +130,7 @@ import Data.Foldable (foldr')
130#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
130#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
131import Data.List (nub)
131import Data.List (nub)
133−import Data.List (find, foldl', genericLength , intercalate , intersperse, partition, union)
133+import Data.List (foldl', genericLength , intercalate , intersperse, partition, union)
134import Data.List.NonEmpty ((<|), NonEmpty((:|)))
134import Data.List.NonEmpty ((<|), NonEmpty((:|)))
135import Data.Map (Map)
135import Data.Map (Map)
136import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
136import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
@@ -140,7 +140,7 @@ import Language.Haskell.TH hiding (Arity)
141import Language.Haskell.TH
141import Language.Haskell.TH
143−import Language.Haskell.TH.Syntax (VarStrictType)
143+import Language.Haskell.TH.Datatype
144#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))
144#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))
145import Language.Haskell.TH.Lib (starK)
145import Language.Haskell.TH.Lib (starK)
@@ -152,8 +152,8 @@ import qualified Data.Aeson as A
152import qualified Data.Aeson.Encoding.Internal as E
152import qualified Data.Aeson.Encoding.Internal as E
153import qualified Data.Foldable as F (all)
153import qualified Data.Foldable as F (all)
154import qualified Data.HashMap.Strict as H (lookup, toList)
154import qualified Data.HashMap.Strict as H (lookup, toList)
155−import qualified Data.List.NonEmpty as NE (drop, length, reverse, splitAt)
155+import qualified Data.List.NonEmpty as NE (length, reverse)
156−import qualified Data.Map as M (fromList, findWithDefault, keys, lookup , singleton, size)
156+import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
157import qualified Data.Set as Set (empty, insert, member)
157import qualified Data.Set as Set (empty, insert, member)
158import qualified Data.Text as T (Text, pack, unpack)
158import qualified Data.Text as T (Text, pack, unpack)
159import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)
159import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)
@@ -322,32 +322,36 @@ consToValue :: JSONClass
322 -- ^ The ToJSON variant being derived.
322 -- ^ The ToJSON variant being derived.
323 -> Options
323 -> Options
324 -- ^ Encoding options.
324 -- ^ Encoding options.
325− -> [Con]
325+ -> [Type]
326+ -- ^ The types from the data type/data family instance declaration
327+ -> [ConstructorInfo]
326 -- ^ Constructors for which to generate JSON generating code.
328 -- ^ Constructors for which to generate JSON generating code.
329−consToValue _ _ [] = error $ "Data.Aeson.TH.consToValue: "
331+consToValue _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
330− ++ "Not a single constructor given!"
332+ ++ "Not a single constructor given!"
332−consToValue jc opts cons = do
334+consToValue jc opts vars cons = do
333 value <- newName "value"
335 value <- newName "value"
334 tjs <- newNameList "_tj" $ arityInt jc
336 tjs <- newNameList "_tj" $ arityInt jc
335 tjls <- newNameList "_tjl" $ arityInt jc
337 tjls <- newNameList "_tjl" $ arityInt jc
336 let zippedTJs = zip tjs tjls
338 let zippedTJs = zip tjs tjls
337 interleavedTJs = interleave tjs tjls
339 interleavedTJs = interleave tjs tjls
340+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
341+ tvMap = M.fromList $ zip lastTyVars zippedTJs
338 lamE (map varP $ interleavedTJs ++ [value]) $
342 lamE (map varP $ interleavedTJs ++ [value]) $
339− caseE (varE value) (matches zippedTJs)
343+ caseE (varE value) (matches tvMap)
341− matches tjs = case cons of
345+ matches tvMap = case cons of
342 -- A single constructor is directly encoded. The constructor itself may be
346 -- A single constructor is directly encoded. The constructor itself may be
343 -- forgotten.
347 -- forgotten.
344− [con] | not (tagSingleConstructors opts) -> [argsToValue jc tjs opts False con]
348+ [con] | not (tagSingleConstructors opts) -> [argsToValue jc tvMap opts False con]
345 _ | allNullaryToStringTag opts && all isNullary cons ->
349 _ | allNullaryToStringTag opts && all isNullary cons ->
346 [ match (conP conName []) (normalB $ conStr opts conName) []
350 [ match (conP conName []) (normalB $ conStr opts conName) []
347 | con <- cons
351 | con <- cons
348− , let conName = getConName con
352+ , let conName = constructorName con
350− | otherwise -> [argsToValue jc tjs opts True con | con <- cons]
354+ | otherwise -> [argsToValue jc tvMap opts True con | con <- cons]
352conStr :: Options -> Name -> Q Exp
356conStr :: Options -> Name -> Q Exp
353conStr opts = appE [|String|] . conTxt opts
357conStr opts = appE [|String|] . conTxt opts
@@ -365,42 +369,47 @@ consToEncoding :: JSONClass
365 -- ^ The ToJSON variant being derived.
369 -- ^ The ToJSON variant being derived.
366 -> Options
370 -> Options
367 -- ^ Encoding options.
371 -- ^ Encoding options.
368− -> [Con]
372+ -> [Type]
373+ -- ^ The types from the data type/data family instance declaration
374+ -> [ConstructorInfo]
369 -- ^ Constructors for which to generate JSON generating code.
375 -- ^ Constructors for which to generate JSON generating code.
372−consToEncoding _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "
378+consToEncoding _ _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "
373− ++ "Not a single constructor given!"
379+ ++ "Not a single constructor given!"
375−consToEncoding jc opts cons = do
381+consToEncoding jc opts vars cons = do
376 value <- newName "value"
382 value <- newName "value"
377 tes <- newNameList "_te" $ arityInt jc
383 tes <- newNameList "_te" $ arityInt jc
378 tels <- newNameList "_tel" $ arityInt jc
384 tels <- newNameList "_tel" $ arityInt jc
379 let zippedTEs = zip tes tels
385 let zippedTEs = zip tes tels
380 interleavedTEs = interleave tes tels
386 interleavedTEs = interleave tes tels
387+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
388+ tvMap = M.fromList $ zip lastTyVars zippedTEs
381 lamE (map varP $ interleavedTEs ++ [value]) $
389 lamE (map varP $ interleavedTEs ++ [value]) $
382− caseE (varE value) (matches zippedTEs)
390+ caseE (varE value) (matches tvMap)
384− matches tes = case cons of
392+ matches tvMap = case cons of
385 -- A single constructor is directly encoded. The constructor itself may be
393 -- A single constructor is directly encoded. The constructor itself may be
386 -- forgotten.
394 -- forgotten.
387− [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tes opts False con]
395+ [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tvMap opts False con]
388 -- Encode just the name of the constructor of a sum type iff all the
396 -- Encode just the name of the constructor of a sum type iff all the
389 -- constructors are nullary.
397 -- constructors are nullary.
390 _ | allNullaryToStringTag opts && all isNullary cons ->
398 _ | allNullaryToStringTag opts && all isNullary cons ->
391 [ match (conP conName [])
399 [ match (conP conName [])
392 (normalB $ encStr opts conName) []
400 (normalB $ encStr opts conName) []
393 | con <- cons
401 | con <- cons
394− , let conName = getConName con
402+ , let conName = constructorName con
396− | otherwise -> [argsToEncoding jc tes opts True con | con <- cons]
404+ | otherwise -> [argsToEncoding jc tvMap opts True con | con <- cons]
398encStr :: Options -> Name -> Q Exp
406encStr :: Options -> Name -> Q Exp
399encStr opts = appE [|E.text|] . conTxt opts
407encStr opts = appE [|E.text|] . conTxt opts
401-- | If constructor is nullary.
409-- | If constructor is nullary.
402−isNullary :: Con -> Bool
410+isNullary :: ConstructorInfo -> Bool
403−isNullary (NormalC _ []) = True
411+isNullary ConstructorInfo { constructorVariant = NormalConstructor
412+ , constructorFields = tys } = null tys
404isNullary _ = False
413isNullary _ = False
406sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
415sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
@@ -423,16 +432,19 @@ sumToValue opts multiCons nullary conName exp
423 | otherwise = exp
432 | otherwise = exp
425-- | Generates code to generate the JSON encoding of a single constructor.
434-- | Generates code to generate the JSON encoding of a single constructor.
426−argsToValue :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match
435+argsToValue :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
428-- Polyadic constructors with special case for unary constructors.
437-- Polyadic constructors with special case for unary constructors.
429−argsToValue jc tjs opts multiCons (NormalC conName ts) = do
438+argsToValue jc tvMap opts multiCons
430− (argTys, tvMap) <- reifyConTys jc tjs conName
439+ ConstructorInfo { constructorName = conName
440+ , constructorVariant = NormalConstructor
441+ , constructorFields = argTys } = do
442+ argTys' <- mapM resolveTypeSynonyms argTys
431− let len = length ts
443+ let len = length argTys'
432 args <- newNameList "arg" len
444 args <- newNameList "arg" len
433 js <- case [ dispatchToJSON jc conName tvMap argTy
445 js <- case [ dispatchToJSON jc conName tvMap argTy
434 `appE` varE arg
446 `appE` varE arg
435− | (arg, argTy) <- zip args argTys
447+ | (arg, argTy) <- zip args argTys'
437 -- Single argument is directly converted.
449 -- Single argument is directly converted.
438 [e] -> return e
450 [e] -> return e
@@ -454,69 +466,77 @@ argsToValue jc tjs opts multiCons (NormalC conName ts) = do
454 (varE 'V.create `appE`
466 (varE 'V.create `appE`
455 doE (newMV:stmts++[ret]))
467 doE (newMV:stmts++[ret]))
456 match (conP conName $ map varP args)
468 match (conP conName $ map varP args)
457− (normalB $ sumToValue opts multiCons (null ts) conName js)
469+ (normalB $ sumToValue opts multiCons (null argTys') conName js)
460-- Records.
472-- Records.
473+argsToValue jc tvMap opts multiCons
474+ info@ConstructorInfo { constructorName = conName
475+ , constructorVariant = RecordConstructor fields
476+ , constructorFields = argTys } =
461−argsToValue jc tjs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
477+ case (unwrapUnaryRecords opts, not multiCons, argTys) of
462− (True,True,[(_,st,ty)]) -> argsToValue jc tjs opts multiCons (NormalC conName [(st,ty)])
478+ (True,True,[_]) -> argsToValue jc tvMap opts multiCons
479+ (info{constructorVariant = NormalConstructor})
464− (argTys, tvMap) <- reifyConTys jc tjs conName
481+ argTys' <- mapM resolveTypeSynonyms argTys
465− args <- newNameList "arg" $ length ts
482+ args <- newNameList "arg" $ length argTys'
466− let exp = [|A.object|] `appE` pairs
483+ let exp = [|A.object|] `appE` pairs
468− pairs | omitNothingFields opts = infixApp maybeFields
485+ pairs | omitNothingFields opts = infixApp maybeFields
469− [|(++)|]
486+ [|(++)|]
470− restFields
487+ restFields
471− | otherwise = listE $ map toPair argCons
488+ | otherwise = listE $ map toPair argCons
473− argCons = zip3 args argTys ts
490+ argCons = zip3 args argTys' fields
475− maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
492+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
477− restFields = listE $ map toPair rest
494+ restFields = listE $ map toPair rest
479− (maybes, rest) = partition isMaybe argCons
496+ (maybes, rest) = partition isMaybe argCons
481− maybeToPair (arg, argTy, (field, _, _)) =
498+ maybeToPair (arg, argTy, field) =
482− infixApp ([|keyValuePairWith|]
499+ infixApp ([|keyValuePairWith|]
483− `appE` dispatchToJSON jc conName tvMap argTy
500+ `appE` dispatchToJSON jc conName tvMap argTy
484− `appE` toFieldName field)
501+ `appE` toFieldName field)
485− [|(<$>)|]
502+ [|(<$>)|]
486− (varE arg)
503+ (varE arg)
488− toPair (arg, argTy, (field, _, _)) =
505+ toPair (arg, argTy, field) =
489− [|keyValuePairWith|]
506+ [|keyValuePairWith|]
490− `appE` dispatchToJSON jc conName tvMap argTy
507+ `appE` dispatchToJSON jc conName tvMap argTy
491− `appE` toFieldName field
508+ `appE` toFieldName field
492− `appE` varE arg
509+ `appE` varE arg
494− toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
511+ toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
496− match (conP conName $ map varP args)
513+ match (conP conName $ map varP args)
497− ( normalB
514+ ( normalB
498− $ if multiCons
515+ $ if multiCons
499− then case sumEncoding opts of
516+ then case sumEncoding opts of
500− TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
517+ TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
501− TaggedObject{tagFieldName} ->
518+ TaggedObject{tagFieldName} ->
502− [|A.object|] `appE`
519+ [|A.object|] `appE`
503− -- TODO: Maybe throw an error in case
520+ -- TODO: Maybe throw an error in case
504− -- tagFieldName overwrites a field in pairs.
521+ -- tagFieldName overwrites a field in pairs.
505− infixApp (infixApp [|T.pack tagFieldName|]
522+ infixApp (infixApp [|T.pack tagFieldName|]
506− [|(.=)|]
523+ [|(.=)|]
507− (conStr opts conName))
524+ (conStr opts conName))
510− ObjectWithSingleField ->
527+ ObjectWithSingleField ->
511− [|A.object|] `appE` listE
528+ [|A.object|] `appE` listE
512− [ infixApp (conTxt opts conName) [|(.=)|] exp ]
529+ [ infixApp (conTxt opts conName) [|(.=)|] exp ]
513− UntaggedValue -> exp
530+ UntaggedValue -> exp
514− else exp
531+ else exp
517-- Infix constructors.
534-- Infix constructors.
518−argsToValue jc tjs opts multiCons (InfixC _ conName _) = do
535+argsToValue jc tvMap opts multiCons
519− ([alTy, arTy], tvMap) <- reifyConTys jc tjs conName
536+ ConstructorInfo { constructorName = conName
537+ , constructorVariant = InfixConstructor
538+ , constructorFields = argTys } = do
539+ [alTy, arTy] <- mapM resolveTypeSynonyms argTys
520 al <- newName "argL"
540 al <- newName "argL"
521 ar <- newName "argR"
541 ar <- newName "argR"
522 match (infixP (varP al) conName (varP ar))
542 match (infixP (varP al) conName (varP ar))
@@ -528,22 +548,10 @@ argsToValue jc tjs opts multiCons (InfixC _ conName _) = do
531−-- Existentially quantified constructors.
532−argsToValue jc tjs opts multiCons (ForallC _ _ con) =
533− argsToValue jc tjs opts multiCons con
535−#if MIN_VERSION_template_haskell(2,11,0)
537−argsToValue jc tjs opts multiCons (GadtC conNames ts _) =
538− argsToValue jc tjs opts multiCons $ NormalC (head conNames) ts
540−argsToValue jc tjs opts multiCons (RecGadtC conNames ts _) =
541− argsToValue jc tjs opts multiCons $ RecC (head conNames) ts
544−isMaybe :: (a, b, (c, d, Type)) -> Bool
552+isMaybe :: (a, Type, b) -> Bool
545−isMaybe (_, _, (_, _, AppT (ConT t) _)) = t == ''Maybe
553+isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe
546−isMaybe _ = False
554+isMaybe _ = False
548(<^>) :: ExpQ -> ExpQ -> ExpQ
556(<^>) :: ExpQ -> ExpQ -> ExpQ
549(<^>) a b = infixApp a [|(E.><)|] b
557(<^>) a b = infixApp a [|(E.><)|] b
@@ -583,14 +591,16 @@ sumToEncoding opts multiCons nullary conName exp
583 | otherwise = exp
591 | otherwise = exp
585-- | Generates code to generate the JSON encoding of a single constructor.
593-- | Generates code to generate the JSON encoding of a single constructor.
586−argsToEncoding :: JSONClass -> [(Name, Name)] -> Options -> Bool -> Con -> Q Match
594+argsToEncoding :: JSONClass -> TyVarMap -> Options -> Bool -> ConstructorInfo -> Q Match
588-- Polyadic constructors with special case for unary constructors.
596-- Polyadic constructors with special case for unary constructors.
589−argsToEncoding jc tes opts multiCons (NormalC conName ts) = do
597+argsToEncoding jc tvMap opts multiCons
590− (argTys, tvMap) <- reifyConTys jc tes conName
598+ ConstructorInfo { constructorName = conName
591− let len = length ts
599+ , constructorVariant = NormalConstructor
600+ , constructorFields = argTys } = do
601+ argTys' <- mapM resolveTypeSynonyms argTys
592− args <- newNameList "arg" len
602+ args <- newNameList "arg" $ length argTys'
593− js <- case zip args argTys of
603+ js <- case zip args argTys' of
594 -- Nullary constructors are converted to an empty array.
604 -- Nullary constructors are converted to an empty array.
595 [] -> return [| E.emptyArray_ |]
605 [] -> return [| E.emptyArray_ |]
@@ -604,73 +614,81 @@ argsToEncoding jc tes opts multiCons (NormalC conName ts) = do
604 | (x,xTy) <- es
614 | (x,xTy) <- es
606 match (conP conName $ map varP args)
616 match (conP conName $ map varP args)
607− (normalB $ sumToEncoding opts multiCons (null ts) conName js)
617+ (normalB $ sumToEncoding opts multiCons (null argTys') conName js)
610-- Records.
620-- Records.
621+argsToEncoding jc tvMap opts multiCons
622+ info@ConstructorInfo { constructorName = conName
623+ , constructorVariant = RecordConstructor fields
624+ , constructorFields = argTys } =
611−argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
625+ case (unwrapUnaryRecords opts, not multiCons, argTys) of
612− (True,True,[(_,st,ty)]) -> argsToEncoding jc tes opts multiCons (NormalC conName [(st,ty)])
626+ (True,True,[_]) -> argsToEncoding jc tvMap opts multiCons
627+ (info{constructorVariant = NormalConstructor})
629+ argTys' <- mapM resolveTypeSynonyms argTys
614− args <- newNameList "arg" $ length ts
630+ args <- newNameList "arg" $ length argTys'
615− (argTys, tvMap) <- reifyConTys jc tes conName
616− let exp = object objBody
631+ let exp = object objBody
618− objBody = [|E.econcat|] `appE`
633+ objBody = [|E.econcat|] `appE`
619− ([|intersperse E.comma|] `appE` pairs)
634+ ([|intersperse E.comma|] `appE` pairs)
620− pairs | omitNothingFields opts = infixApp maybeFields
635+ pairs | omitNothingFields opts = infixApp maybeFields
621− [|(++)|]
636+ [|(++)|]
622− restFields
637+ restFields
623− | otherwise = listE (map toPair argCons)
638+ | otherwise = listE (map toPair argCons)
625− argCons = zip3 args argTys ts
640+ argCons = zip3 args argTys' fields
627− maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
642+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
629− restFields = listE (map toPair rest)
644+ restFields = listE (map toPair rest)
631− (maybes, rest) = partition isMaybe argCons
646+ (maybes, rest) = partition isMaybe argCons
633− maybeToPair (arg, argTy, (field, _, _)) =
648+ maybeToPair (arg, argTy, field) =
634− infixApp
649+ infixApp
635− (infixApp
650+ (infixApp
637− (Just $ toFieldName field <^> [|E.colon|])
652+ (Just $ toFieldName field <^> [|E.colon|])
638− [|(E.><)|]
653+ [|(E.><)|]
639− Nothing)
654+ Nothing)
641− (dispatchToEncoding jc conName tvMap argTy))
656+ (dispatchToEncoding jc conName tvMap argTy))
642− [|(<$>)|]
657+ [|(<$>)|]
643− (varE arg)
658+ (varE arg)
645− toPair (arg, argTy, (field, _, _)) =
660+ toPair (arg, argTy, field) =
646− toFieldName field
661+ toFieldName field
647− <:> dispatchToEncoding jc conName tvMap argTy
662+ <:> dispatchToEncoding jc conName tvMap argTy
648− `appE` varE arg
663+ `appE` varE arg
650− toFieldName field = [|E.text|] `appE`
665+ toFieldName field = [|E.text|] `appE`
651− ([|T.pack|] `appE` fieldLabelExp opts field)
666+ ([|T.pack|] `appE` fieldLabelExp opts field)
653− match (conP conName $ map varP args)
668+ match (conP conName $ map varP args)
654− ( normalB
669+ ( normalB
655− $ if multiCons
670+ $ if multiCons
656− then case sumEncoding opts of
671+ then case sumEncoding opts of
657− TwoElemArray -> array $
672+ TwoElemArray -> array $
658− encStr opts conName <%> exp
673+ encStr opts conName <%> exp
659− TaggedObject{tagFieldName} -> object $
674+ TaggedObject{tagFieldName} -> object $
660− ([|E.text (T.pack tagFieldName)|] <:>
675+ ([|E.text (T.pack tagFieldName)|] <:>
661− encStr opts conName) <%>
676+ encStr opts conName) <%>
663− ObjectWithSingleField -> object $
678+ ObjectWithSingleField -> object $
664− encStr opts conName <:> exp
679+ encStr opts conName <:> exp
665− UntaggedValue -> exp
680+ UntaggedValue -> exp
666− else exp
681+ else exp
669-- Infix constructors.
684-- Infix constructors.
670−argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do
685+argsToEncoding jc tvMap opts multiCons
686+ ConstructorInfo { constructorName = conName
687+ , constructorVariant = InfixConstructor
688+ , constructorFields = argTys } = do
671 al <- newName "argL"
689 al <- newName "argL"
672 ar <- newName "argR"
690 ar <- newName "argR"
673− ([alTy,arTy], tvMap) <- reifyConTys jc tes conName
691+ [alTy,arTy] <- mapM resolveTypeSynonyms argTys
674 match (infixP (varP al) conName (varP ar))
692 match (infixP (varP al) conName (varP ar))
675 ( normalB
693 ( normalB
676 $ sumToEncoding opts multiCons False conName
694 $ sumToEncoding opts multiCons False conName
@@ -680,18 +698,6 @@ argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do
683−-- Existentially quantified constructors.
684−argsToEncoding jc tes opts multiCons (ForallC _ _ con) =
685− argsToEncoding jc tes opts multiCons con
687−#if MIN_VERSION_template_haskell(2,11,0)
689−argsToEncoding jc tes opts multiCons (GadtC conNames ts _) =
690− argsToEncoding jc tes opts multiCons $ NormalC (head conNames) ts
692−argsToEncoding jc tes opts multiCons (RecGadtC conNames ts _) =
693− argsToEncoding jc tes opts multiCons $ RecC (head conNames) ts
696--------------------------------------------------------------------------------
702--------------------------------------------------------------------------------
697-- FromJSON
703-- FromJSON
@@ -775,33 +781,41 @@ consFromJSON :: JSONClass
775 -- ^ Name of the type to which the constructors belong.
781 -- ^ Name of the type to which the constructors belong.
776 -> Options
782 -> Options
777 -- ^ Encoding options
783 -- ^ Encoding options
778− -> [Con]
784+ -> [Type]
785+ -- ^ The types from the data type/data family instance declaration
786+ -> [ConstructorInfo]
779 -- ^ Constructors for which to generate JSON parsing code.
787 -- ^ Constructors for which to generate JSON parsing code.
782−consFromJSON _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
790+consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
783− ++ "Not a single constructor given!"
791+ ++ "Not a single constructor given!"
785−consFromJSON jc tName opts cons = do
793+consFromJSON jc tName opts vars cons = do
786 value <- newName "value"
794 value <- newName "value"
787 pjs <- newNameList "_pj" $ arityInt jc
795 pjs <- newNameList "_pj" $ arityInt jc
788 pjls <- newNameList "_pjl" $ arityInt jc
796 pjls <- newNameList "_pjl" $ arityInt jc
789 let zippedPJs = zip pjs pjls
797 let zippedPJs = zip pjs pjls
790 interleavedPJs = interleave pjs pjls
798 interleavedPJs = interleave pjs pjls
799+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
800+ tvMap = M.fromList $ zip lastTyVars zippedPJs
791− lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value zippedPJs
801+ lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap
804+ checkExi tvMap con = checkExistentialContext jc tvMap
805+ (constructorContext con)
806+ (constructorName con)
794− lamExpr value pjs = case cons of
808+ lamExpr value tvMap = case cons of
796 | not (tagSingleConstructors opts)
810 | not (tagSingleConstructors opts)
797− -> parseArgs jc pjs tName opts con (Right value)
811+ -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)
798 _ | sumEncoding opts == UntaggedValue
812 _ | sumEncoding opts == UntaggedValue
799− -> parseUntaggedValue pjs cons value
813+ -> parseUntaggedValue tvMap cons value
800 | otherwise
814 | otherwise
801 -> caseE (varE value) $
815 -> caseE (varE value) $
802 if allNullaryToStringTag opts && all isNullary cons
816 if allNullaryToStringTag opts && all isNullary cons
803 then allNullaryMatches
817 then allNullaryMatches
804− else mixedMatches pjs
818+ else mixedMatches tvMap
806 allNullaryMatches =
820 allNullaryMatches =
807 [ do txt <- newName "txt"
821 [ do txt <- newName "txt"
@@ -815,7 +829,7 @@ consFromJSON jc tName opts cons = do
816 ([|pure|] `appE` conE conName)
830 ([|pure|] `appE` conE conName)
817 | con <- cons
831 | con <- cons
818− , let conName = getConName con
832+ , let conName = constructorName con
821 [ liftM2 (,)
835 [ liftM2 (,)
@@ -836,13 +850,13 @@ consFromJSON jc tName opts cons = do
839− mixedMatches pjs =
853+ mixedMatches tvMap =
840 case sumEncoding opts of
854 case sumEncoding opts of
841 TaggedObject {tagFieldName, contentsFieldName} ->
855 TaggedObject {tagFieldName, contentsFieldName} ->
842− parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName
856+ parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
843 UntaggedValue -> error "UntaggedValue: Should be handled already"
857 UntaggedValue -> error "UntaggedValue: Should be handled already"
844 ObjectWithSingleField ->
858 ObjectWithSingleField ->
845− parseObject $ parseObjectWithSingleField pjs
859+ parseObject $ parseObjectWithSingleField tvMap
846 TwoElemArray ->
860 TwoElemArray ->
847 [ do arr <- newName "array"
861 [ do arr <- newName "array"
848 match (conP 'Array [varP arr])
862 match (conP 'Array [varP arr])
@@ -850,7 +864,7 @@ consFromJSON jc tName opts cons = do
850 [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
864 [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
852 (litE $ integerL 2))
866 (litE $ integerL 2))
853− (parse2ElemArray pjs arr)
867+ (parse2ElemArray tvMap arr)
854 , liftM2 (,) (normalG [|otherwise|])
868 , liftM2 (,) (normalG [|otherwise|])
855 ([|not2ElemArray|]
869 ([|not2ElemArray|]
856 `appE` litE (stringL $ show tName)
870 `appE` litE (stringL $ show tName)
@@ -881,20 +895,24 @@ consFromJSON jc tName opts cons = do
884− parseTaggedObject pjs typFieldName valFieldName obj = do
898+ parseTaggedObject tvMap typFieldName valFieldName obj = do
885 conKey <- newName "conKey"
899 conKey <- newName "conKey"
886 doE [ bindS (varP conKey)
900 doE [ bindS (varP conKey)
887 (infixApp (varE obj)
901 (infixApp (varE obj)
889 ([|T.pack|] `appE` stringE typFieldName))
903 ([|T.pack|] `appE` stringE typFieldName))
890− , noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
904+ , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
893− parseUntaggedValue pjs cons' conVal =
907+ parseUntaggedValue tvMap cons' conVal =
894 foldr1 (\e e' -> infixApp e [|(<|>)|] e')
908 foldr1 (\e e' -> infixApp e [|(<|>)|] e')
895− (map (\x -> parseValue pjs x conVal) cons')
909+ (map (\x -> parseValue tvMap x conVal) cons')
897− parseValue _pjs (NormalC conName []) conVal = do
911+ parseValue _tvMap
912+ ConstructorInfo { constructorName = conName
913+ , constructorVariant = NormalConstructor
914+ , constructorFields = [] }
898 str <- newName "str"
916 str <- newName "str"
899 caseE (varE conVal)
917 caseE (varE conVal)
900 [ match (conP 'String [varP str])
918 [ match (conP 'String [varP str])
@@ -907,11 +925,11 @@ consFromJSON jc tName opts cons = do
908 , matchFailed tName conName "String"
926 , matchFailed tName conName "String"
910− parseValue pjs con conVal =
928+ parseValue tvMap con conVal =
911− parseArgs jc pjs tName opts con (Right conVal)
929+ checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)
914− parse2ElemArray pjs arr = do
932+ parse2ElemArray tvMap arr = do
915 conKey <- newName "conKey"
933 conKey <- newName "conKey"
916 conVal <- newName "conVal"
934 conVal <- newName "conVal"
917 let letIx n ix =
935 let letIx n ix =
@@ -926,7 +944,7 @@ consFromJSON jc tName opts cons = do
926 (caseE (varE conKey)
944 (caseE (varE conKey)
927 [ do txt <- newName "txt"
945 [ do txt <- newName "txt"
928 match (conP 'String [varP txt])
946 match (conP 'String [varP txt])
929− (normalB $ parseContents pjs
947+ (normalB $ parseContents tvMap
931 (Right conVal)
949 (Right conVal)
932 'conNotFoundFail2ElemArray
950 'conNotFoundFail2ElemArray
@@ -943,12 +961,12 @@ consFromJSON jc tName opts cons = do
946− parseObjectWithSingleField pjs obj = do
964+ parseObjectWithSingleField tvMap obj = do
947 conKey <- newName "conKey"
965 conKey <- newName "conKey"
948 conVal <- newName "conVal"
966 conVal <- newName "conVal"
949 caseE ([e|H.toList|] `appE` varE obj)
967 caseE ([e|H.toList|] `appE` varE obj)
950 [ match (listP [tupP [varP conKey, varP conVal]])
968 [ match (listP [tupP [varP conKey, varP conVal]])
951− (normalB $ parseContents pjs conKey (Right conVal) 'conNotFoundFailObjectSingleField)
969+ (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField)
953 , do other <- newName "other"
971 , do other <- newName "other"
954 match (varP other)
972 match (varP other)
@@ -959,7 +977,7 @@ consFromJSON jc tName opts cons = do
962− parseContents pjs conKey contents errorFun =
980+ parseContents tvMap conKey contents errorFun =
963 caseE (varE conKey)
981 caseE (varE conKey)
964 [ match wildP
982 [ match wildP
965 ( guardedB $
983 ( guardedB $
@@ -967,7 +985,8 @@ consFromJSON jc tName opts cons = do
968 ([|T.pack|] `appE`
986 ([|T.pack|] `appE`
969 conNameExp opts con)
987 conNameExp opts con)
988+ e <- checkExi tvMap con $
970− e <- parseArgs jc pjs tName opts con contents
989+ parseArgs jc tvMap tName opts con contents
971 return (g, e)
990 return (g, e)
972 | con <- cons
991 | con <- cons
@@ -980,7 +999,7 @@ consFromJSON jc tName opts cons = do
980 . stringL
999 . stringL
981 . constructorTagModifier opts
1000 . constructorTagModifier opts
982 . nameBase
1001 . nameBase
983− . getConName
1002+ . constructorName
986 `appE` ([|T.unpack|] `appE` varE conKey)
1005 `appE` ([|T.unpack|] `appE` varE conKey)
@@ -1029,10 +1048,10 @@ parseRecord :: JSONClass
1029 -> Options
1048 -> Options
1032− -> [VarStrictType]
1051+ -> [Name]
1035−parseRecord jc tvMap argTys opts tName conName ts obj =
1054+parseRecord jc tvMap argTys opts tName conName fields obj =
1036 foldl' (\a b -> infixApp a [|(<*>)|] b)
1055 foldl' (\a b -> infixApp a [|(<*>)|] b)
1037 (infixApp (conE conName) [|(<$>)|] x)
1056 (infixApp (conE conName) [|(<$>)|] x)
@@ -1044,7 +1063,7 @@ parseRecord jc tvMap argTys opts tName conName ts obj =
1044 `appE` varE obj
1063 `appE` varE obj
1045 `appE` ( [|T.pack|] `appE` fieldLabelExp opts field
1064 `appE` ( [|T.pack|] `appE` fieldLabelExp opts field
1047− | ((field, _, _), argTy) <- zip ts argTys
1066+ | (field, argTy) <- zip fields argTys
1050getValField :: Name -> String -> [MatchQ] -> Q Exp
1069getValField :: Name -> String -> [MatchQ] -> Q Exp
@@ -1063,67 +1082,82 @@ matchCases (Right valName) = caseE (varE valName)
1064-- | Generates code to parse the JSON encoding of a single constructor.
1083-- | Generates code to parse the JSON encoding of a single constructor.
1065parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
1084parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
1085+ -> TyVarMap -- ^ Maps the last type variables to their decoding
1066− -> [(Name, Name)] -- ^ The names of the encoding/decoding function arguments.
1086+ -- function arguments.
1067 -> Name -- ^ Name of the type to which the constructor belongs.
1087 -> Name -- ^ Name of the type to which the constructor belongs.
1068 -> Options -- ^ Encoding options.
1088 -> Options -- ^ Encoding options.
1069− -> Con -- ^ Constructor for which to generate JSON parsing code.
1089+ -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.
1070 -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
1090 -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
1071 -- Right valName
1091 -- Right valName
1072 -> Q Exp
1092 -> Q Exp
1073-- Nullary constructors.
1093-- Nullary constructors.
1074−parseArgs jc pjs _ _ (NormalC conName []) (Left _) = do
1094+parseArgs _ _ _ _
1075− ([], _) <- reifyConTys jc pjs conName
1095+ ConstructorInfo { constructorName = conName
1096+ , constructorVariant = NormalConstructor
1097+ , constructorFields = [] }
1076− [|pure|] `appE` conE conName
1099+ [|pure|] `appE` conE conName
1077−parseArgs jc pjs tName _ (NormalC conName []) (Right valName) = do
1100+parseArgs _ _ tName _
1078− ([], _) <- reifyConTys jc pjs conName
1101+ ConstructorInfo { constructorName = conName
1102+ , constructorVariant = NormalConstructor
1103+ , constructorFields = [] }
1079− caseE (varE valName) $ parseNullaryMatches tName conName
1105+ caseE (varE valName) $ parseNullaryMatches tName conName
1081-- Unary constructors.
1107-- Unary constructors.
1082−parseArgs jc pjs _ _ (NormalC conName [_]) contents = do
1108+parseArgs jc tvMap _ _
1083− ([argTy], tvMap) <- reifyConTys jc pjs conName
1109+ ConstructorInfo { constructorName = conName
1110+ , constructorVariant = NormalConstructor
1111+ , constructorFields = [argTy] }
1113+ argTy' <- resolveTypeSynonyms argTy
1084− matchCases contents $ parseUnaryMatches jc tvMap argTy conName
1114+ matchCases contents $ parseUnaryMatches jc tvMap argTy' conName
1086-- Polyadic constructors.
1116-- Polyadic constructors.
1087−parseArgs jc pjs tName _ (NormalC conName ts) contents = do
1117+parseArgs jc tvMap tName _
1088− (argTys, tvMap) <- reifyConTys jc pjs conName
1118+ ConstructorInfo { constructorName = conName
1119+ , constructorVariant = NormalConstructor
1120+ , constructorFields = argTys }
1122+ argTys' <- mapM resolveTypeSynonyms argTys
1089− let len = genericLength ts
1123+ let len = genericLength argTys'
1090− matchCases contents $ parseProduct jc tvMap argTys tName conName len
1124+ matchCases contents $ parseProduct jc tvMap argTys' tName conName len
1092-- Records.
1126-- Records.
1093−parseArgs jc pjs tName opts (RecC conName ts) (Left (_, obj)) = do
1127+parseArgs jc tvMap tName opts
1094− (argTys, tvMap) <- reifyConTys jc pjs conName
1128+ ConstructorInfo { constructorName = conName
1129+ , constructorVariant = RecordConstructor fields
1130+ , constructorFields = argTys }
1131+ (Left (_, obj)) = do
1132+ argTys' <- mapM resolveTypeSynonyms argTys
1095− parseRecord jc tvMap argTys opts tName conName ts obj
1133+ parseRecord jc tvMap argTys' opts tName conName fields obj
1134+parseArgs jc tvMap tName opts
1135+ info@ConstructorInfo { constructorName = conName
1136+ , constructorVariant = RecordConstructor fields
1137+ , constructorFields = argTys }
1096−parseArgs jc pjs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of
1139+ case (unwrapUnaryRecords opts,argTys) of
1097− (True,[(_,st,ty)])-> parseArgs jc pjs tName opts (NormalC conName [(st,ty)]) (Right valName)
1140+ (True,[_])-> parseArgs jc tvMap tName opts
1141+ (info{constructorVariant = NormalConstructor})
1098− _ -> do
1143+ _ -> do
1099− obj <- newName "recObj"
1144+ obj <- newName "recObj"
1100− (argTys, tvMap) <- reifyConTys jc pjs conName
1145+ argTys' <- mapM resolveTypeSynonyms argTys
1101− caseE (varE valName)
1146+ caseE (varE valName)
1102− [ match (conP 'Object [varP obj]) (normalB $
1147+ [ match (conP 'Object [varP obj]) (normalB $
1103− parseRecord jc tvMap argTys opts tName conName ts obj) []
1148+ parseRecord jc tvMap argTys' opts tName conName fields obj) []
1104− , matchFailed tName conName "Object"
1149+ , matchFailed tName conName "Object"
1107-- Infix constructors. Apart from syntax these are the same as
1152-- Infix constructors. Apart from syntax these are the same as
1108-- polyadic constructors.
1153-- polyadic constructors.
1109−parseArgs jc pjs tName _ (InfixC _ conName _) contents = do
1154+parseArgs jc tvMap tName _
1110− (argTys, tvMap) <- reifyConTys jc pjs conName
1155+ ConstructorInfo { constructorName = conName
1156+ , constructorVariant = InfixConstructor
1157+ , constructorFields = argTys }
1159+ argTys' <- mapM resolveTypeSynonyms argTys
1111− matchCases contents $ parseProduct jc tvMap argTys tName conName 2
1160+ matchCases contents $ parseProduct jc tvMap argTys' tName conName 2
1113−-- Existentially quantified constructors. We ignore the quantifiers
1114−-- and proceed with the contained constructor.
1115−parseArgs jc pjs tName opts (ForallC _ _ con) contents =
1116− parseArgs jc pjs tName opts con contents
1118−#if MIN_VERSION_template_haskell(2,11,0)
1119−-- GADTs. We ignore the refined return type and proceed as if it were a
1121−parseArgs jc pjs tName opts (GadtC conNames ts _) contents =
1122− parseArgs jc pjs tName opts (NormalC (head conNames) ts) contents
1124−parseArgs jc pjs tName opts (RecGadtC conNames ts _) contents =
1125− parseArgs jc pjs tName opts (RecC (head conNames) ts) contents
1128-- | Generates code to parse the JSON encoding of an n-ary
1162-- | Generates code to parse the JSON encoding of an n-ary
1129-- constructor.
1163-- constructor.
@@ -1278,7 +1312,8 @@ deriveJSONBoth dtj dfj opts name =
1278 liftM2 (++) (dtj opts name) (dfj opts name)
1312 liftM2 (++) (dtj opts name) (dfj opts name)
1280-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.
1314-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.
1281−deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]
1315+deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]
1316+ -> [ConstructorInfo] -> Q Exp)]
1282 -- ^ The class methods and the functions which derive them.
1317 -- ^ The class methods and the functions which derive them.
1283 -> JSONClass
1318 -> JSONClass
1284 -- ^ The class for which to generate an instance.
1319 -- ^ The class for which to generate an instance.
@@ -1288,27 +1323,30 @@ deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]
1288 -- ^ Name of the type for which to generate a class instance
1323 -- ^ Name of the type for which to generate a class instance
1289 -- declaration.
1324 -- declaration.
1290 -> Q [Dec]
1325 -> Q [Dec]
1291−deriveJSONClass consFuns jc opts name =
1326+deriveJSONClass consFuns jc opts name = do
1292− withType name $ \name' ctxt tvbs cons mbTys ->
1327+ info <- reifyDatatype name
1293− (:[]) <$> fromCons name' ctxt tvbs cons mbTys
1328+ case info of
1294− where
1329+ DatatypeInfo { datatypeContext = ctxt
1295− fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
1330+ , datatypeName = parentName
1296− fromCons name' ctxt tvbs cons mbTys = do
1331+ , datatypeVars = vars
1332+ , datatypeVariant = variant
1333+ , datatypeCons = cons
1297 (instanceCxt, instanceType)
1335 (instanceCxt, instanceType)
1298− <- buildTypeInstance name' jc ctxt tvbs mbTys
1336+ <- buildTypeInstance parentName jc ctxt vars variant
1299− instanceD (return instanceCxt)
1337+ (:[]) <$> instanceD (return instanceCxt)
1300− (return instanceType)
1338+ (return instanceType)
1301− (methodDecs name' cons)
1339+ (methodDecs parentName vars cons)
1303− methodDecs :: Name -> [Con] -> [Q Dec]
1341+ methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
1304− methodDecs name' cons = flip map consFuns $ \(jf, jfMaker) ->
1342+ methodDecs parentName vars cons = flip map consFuns $ \(jf, jfMaker) ->
1305 funD (jsonFunValName jf (arity jc))
1343 funD (jsonFunValName jf (arity jc))
1306 [ clause []
1344 [ clause []
1307− (normalB $ jfMaker jc name' opts cons)
1345+ (normalB $ jfMaker jc parentName opts vars cons)
1311−mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)
1349+mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
1312 -- ^ The function which derives the expression.
1350 -- ^ The function which derives the expression.
1313 -> JSONClass
1351 -> JSONClass
1314 -- ^ Which class's method is being derived.
1352 -- ^ Which class's method is being derived.
@@ -1317,15 +1355,20 @@ mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)
1318 -- ^ Name of the encoded type.
1356 -- ^ Name of the encoded type.
1319 -> Q Exp
1357 -> Q Exp
1320−mkFunCommon consFun jc opts name = withType name fromCons
1358+mkFunCommon consFun jc opts name = do
1321− where
1359+ info <- reifyDatatype name
1322− fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
1360+ case info of
1323− fromCons name' ctxt tvbs cons mbTys = do
1361+ DatatypeInfo { datatypeContext = ctxt
1362+ , datatypeName = parentName
1363+ , datatypeVars = vars
1364+ , datatypeVariant = variant
1365+ , datatypeCons = cons
1324− -- We force buildTypeInstance here since it performs some checks for whether
1367+ -- We force buildTypeInstance here since it performs some checks for whether
1325− -- or not the provided datatype's kind matches the derived method's
1368+ -- or not the provided datatype's kind matches the derived method's
1326− -- typeclass, and produces errors if it can't.
1369+ -- typeclass, and produces errors if it can't.
1327− !_ <- buildTypeInstance name' jc ctxt tvbs mbTys
1370+ !_ <- buildTypeInstance parentName jc ctxt vars variant
1328− consFun jc name' opts cons
1371+ consFun jc parentName opts vars cons
1330dispatchFunByType :: JSONClass
1373dispatchFunByType :: JSONClass
1331 -> JSONFun
1374 -> JSONFun
@@ -1380,190 +1423,24 @@ dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False
1380-- Utility functions
1423-- Utility functions
1381--------------------------------------------------------------------------------
1424--------------------------------------------------------------------------------
1383−-- | Boilerplate for top level splices.
1426+-- For the given Types, generate an instance context and head.
1385−-- The given 'Name' must meet one of two criteria:
1387−-- 1. It must be the name of a type constructor of a plain data type or newtype.
1388−-- 2. It must be the name of a data family instance or newtype instance constructor.
1390−-- Any other value will result in an exception.
1392− -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)
1393− -- ^ Function that generates the actual code. Will be applied
1394− -- to the datatype/data family 'Name', datatype context, type
1395− -- variable binders and constructors extracted from the given
1396− -- 'Name'. If the 'Name' is from a data family instance
1397− -- constructor, it will also have its instantiated types;
1398− -- otherwise, it will be 'Nothing'.
1400− -- ^ Resulting value in the 'Q'uasi monad.
1401−withType name f = do
1406−#if MIN_VERSION_template_haskell(2,11,0)
1407− DataD ctxt _ tvbs _ cons _ -> f name ctxt tvbs cons Nothing
1408− NewtypeD ctxt _ tvbs _ con _ -> f name ctxt tvbs [con] Nothing
1410− DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing
1411− NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing
1413− other -> fail $ ns ++ "Unsupported type: " ++ show other
1414−#if MIN_VERSION_template_haskell(2,11,0)
1415− DataConI _ _ parentName -> do
1417− DataConI _ _ parentName _ -> do
1419− parentInfo <- reify parentName
1421−#if MIN_VERSION_template_haskell(2,11,0)
1422− FamilyI (DataFamilyD _ tvbs _) decs ->
1424− FamilyI (FamilyD DataFam _ tvbs _) decs ->
1426− let instDec = flip find decs $ \dec -> case dec of
1427−#if MIN_VERSION_template_haskell(2,11,0)
1428− DataInstD _ _ _ _ cons _ -> any ((name ==) . getConName) cons
1429− NewtypeInstD _ _ _ _ con _ -> name == getConName con
1431− DataInstD _ _ _ cons _ -> any ((name ==) . getConName) cons
1432− NewtypeInstD _ _ _ con _ -> name == getConName con
1434− _ -> error $ ns ++ "Must be a data or newtype instance."
1436−#if MIN_VERSION_template_haskell(2,11,0)
1437− Just (DataInstD ctxt _ instTys _ cons _) -> f parentName ctxt tvbs cons $ Just instTys
1438− Just (NewtypeInstD ctxt _ instTys _ con _) -> f parentName ctxt tvbs [con] $ Just instTys
1440− Just (DataInstD ctxt _ instTys cons _) -> f parentName ctxt tvbs cons $ Just instTys
1441− Just (NewtypeInstD ctxt _ instTys con _) -> f parentName ctxt tvbs [con] $ Just instTys
1444− "Could not find data or newtype instance constructor."
1445− _ -> fail $ ns ++ "Data constructor " ++ show name ++
1446− " is not from a data family instance constructor."
1447−#if MIN_VERSION_template_haskell(2,11,0)
1448− FamilyI DataFamilyD{} _ ->
1450− FamilyI (FamilyD DataFam _ _ _) _ ->
1453− "Cannot use a data family name. Use a data family instance constructor instead."
1454− _ -> fail $ ns ++ "I need the name of a plain data type constructor, "
1455− ++ "or a data family instance constructor."
1458− ns = "Data.Aeson.TH.withType: "
1460−-- | Infer the context and instance head needed for a FromJSON or ToJSON instance.
1461buildTypeInstance :: Name
1427buildTypeInstance :: Name
1462 -- ^ The type constructor or data family name
1428 -- ^ The type constructor or data family name
1463 -> JSONClass
1429 -> JSONClass
1464 -- ^ The typeclass to derive
1430 -- ^ The typeclass to derive
1466 -- ^ The datatype context
1432 -- ^ The datatype context
1467− -> [TyVarBndr]
1433+ -> [Type]
1468− -- ^ The type variables from the data type/data family declaration
1434+ -- ^ The types to instantiate the instance with
1469− -> Maybe [Type]
1435+ -> DatatypeVariant
1470− -- ^ 'Just' the types used to instantiate a data family instance,
1436+ -- ^ Are we dealing with a data family instance or not
1471− -- or 'Nothing' if it's a plain data type
1472 -> Q (Cxt, Type)
1437 -> Q (Cxt, Type)
1473− -- ^ The resulting 'Cxt' and 'Type' to use in a class instance
1474−-- Plain data type/newtype case
1475−buildTypeInstance tyConName jc dataCxt tvbs Nothing =
1476− let varTys :: [Type]
1477− varTys = map tvbToType tvbs
1478− in buildTypeInstanceFromTys tyConName jc dataCxt varTys False
1479−-- Data family instance case
1481−-- The CPP is present to work around a couple of annoying old GHC bugs.
1482−-- See Note [Polykinded data families in Template Haskell]
1483−buildTypeInstance dataFamName jc dataCxt tvbs (Just instTysAndKinds) = do
1484−#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)
1485− let instTys :: [Type]
1486− instTys = zipWith stealKindForType tvbs instTysAndKinds
1488− let kindVarNames :: [Name]
1489− kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs
1492− numKindVars = length kindVarNames
1494− givenKinds, givenKinds' :: [Kind]
1496− (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds
1497− givenKinds' = map sanitizeStars givenKinds
1499− -- A GHC 7.6-specific bug requires us to replace all occurrences of
1500− -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.
1501− -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.
1502− sanitizeStars :: Kind -> Kind
1506− go (AppT t1 t2) = AppT (go t1) (go t2)
1507− go (SigT t k) = SigT (go t) (go k)
1508− go (ConT n) | n == starKindName = StarT
1511− -- It's quite awkward to import * from GHC.Prim, so we'll just
1512− -- hack our way around it.
1513− starKindName :: Name
1514− starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"
1516− -- If we run this code with GHC 7.8, we might have to generate extra type
1517− -- variables to compensate for any type variables that Template Haskell
1518− -- eta-reduced away.
1519− -- See Note [Polykinded data families in Template Haskell]
1520− xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)
1523− xTys = map VarT xTypeNames
1524− -- ^ Because these type variables were eta-reduced away, we can only
1525− -- determine their kind by using stealKindForType. Therefore, we mark
1526− -- them as VarT to ensure they will be given an explicit kind annotation
1527− -- (and so the kind inference machinery has the right information).
1529− substNamesWithKinds :: [(Name, Kind)] -> Type -> Type
1530− substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks
1532− -- The types from the data family instance might not have explicit kind
1533− -- annotations, which the kind machinery needs to work correctly. To
1534− -- compensate, we use stealKindForType to explicitly annotate any
1535− -- types without kind annotations.
1537− instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))
1538− -- Note that due to a GHC 7.8-specific bug
1539− -- (see Note [Polykinded data families in Template Haskell]),
1540− -- there may be more kind variable names than there are kinds
1541− -- to substitute. But this is OK! If a kind is eta-reduced, it
1542− -- means that is was not instantiated to something more specific,
1543− -- so we need not substitute it. Using stealKindForType will
1544− -- grab the correct kind.
1545− $ zipWith stealKindForType tvbs (givenTys ++ xTys)
1547− buildTypeInstanceFromTys dataFamName jc dataCxt instTys True
1549−-- For the given Types, generate an instance context and head.
1550−buildTypeInstanceFromTys :: Name
1551− -- ^ The type constructor or data family name
1553− -- ^ The typeclass to derive
1555− -- ^ The datatype context
1557− -- ^ The types to instantiate the instance with
1559− -- ^ True if it's a data family, False otherwise
1561−buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
1438+buildTypeInstance tyConName jc dataCxt varTysOrig variant = do
1562 -- Make sure to expand through type/kind synonyms! Otherwise, the
1439 -- Make sure to expand through type/kind synonyms! Otherwise, the
1563 -- eta-reduction check might get tripped up over type variables in a
1440 -- eta-reduction check might get tripped up over type variables in a
1564 -- synonym that are actually dropped.
1441 -- synonym that are actually dropped.
1565 -- (See GHC Trac #11416 for a scenario where this actually happened.)
1442 -- (See GHC Trac #11416 for a scenario where this actually happened.)
1566− varTysExp <- mapM expandSyn varTysOrig
1443+ varTysExp <- mapM resolveTypeSynonyms varTysOrig
1568 let remainingLength :: Int
1445 let remainingLength :: Int
1569 remainingLength = length varTysOrig - arityInt jc
1446 remainingLength = length varTysOrig - arityInt jc
@@ -1593,7 +1470,7 @@ buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
1593 -- All of the type variables mentioned in the dropped types
1470 -- All of the type variables mentioned in the dropped types
1594 -- (post-synonym expansion)
1471 -- (post-synonym expansion)
1595 droppedTyVarNames :: [Name]
1472 droppedTyVarNames :: [Name]
1596− droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst
1473+ droppedTyVarNames = freeVariables droppedTysExpSubst
1598 -- If any of the dropped types were polykinded, ensure that they are of kind *
1475 -- If any of the dropped types were polykinded, ensure that they are of kind *
1599 -- after substituting * for the dropped kind variables. If not, throw an error.
1476 -- after substituting * for the dropped kind variables. If not, throw an error.
@@ -1634,6 +1511,13 @@ buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
1634 map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))
1511 map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))
1635 $ take remainingLength varTysOrig
1512 $ take remainingLength varTysOrig
1514+ isDataFamily :: Bool
1515+ isDataFamily = case variant of
1518+ DataInstance -> True
1519+ NewtypeInstance -> True
1637 remainingTysOrigSubst' :: [Type]
1521 remainingTysOrigSubst' :: [Type]
1638 -- See Note [Kind signatures in derived instances] for an explanation
1522 -- See Note [Kind signatures in derived instances] for an explanation
1639 -- of the isDataFamily check.
1523 -- of the isDataFamily check.
@@ -1687,55 +1571,6 @@ deriveConstraint jc t
1687 jcConstraint = jsonClassName . JSONClass (direction jc)
1571 jcConstraint = jsonClassName . JSONClass (direction jc)
1690−Note [Polykinded data families in Template Haskell]
1691−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1693−In order to come up with the correct instance context and head for an instance, e.g.,
1695− instance C a => C (Data a) where ...
1697−We need to know the exact types and kinds used to instantiate the instance. For
1698−plain old datatypes, this is simple: every type must be a type variable, and
1699−Template Haskell reliably tells us the type variables and their kinds.
1701−Doing the same for data families proves to be much harder for three reasons:
1703−1. On any version of Template Haskell, it may not tell you what an instantiated
1704− type's kind is. For instance, in the following data family instance:
1706− data family Fam (f :: * -> *) (a :: *)
1707− data instance Fam f a
1709− Then if we use TH's reify function, it would tell us the TyVarBndrs of the
1710− data family declaration are:
1712− [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]
1714− and the instantiated types of the data family instance are:
1718− We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we
1719− have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the
1720− kind is in case an instantiated type isn't a SigT, so we use the stealKindForType
1721− function to ensure all of the instantiated types are SigTs before passing them
1722− to buildTypeInstanceFromTys.
1723−2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of
1724− the specified kinds of a data family instance efore any of the instantiated
1725− types. Fortunately, this is easy to deal with: you simply count the number of
1726− distinct kind variables in the data family declaration, take that many elements
1727− from the front of the Types list of the data family instance, substitute the
1728− kind variables with their respective instantiated kinds (which you took earlier),
1729− and proceed as normal.
1730−3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template
1731− Haskell might not even list all of the Types of a data family instance, since
1732− they are eta-reduced away! And yes, kinds can be eta-reduced too.
1734− The simplest workaround is to count how many instantiated types are missing from
1735− the list and generate extra type variables to use in their place. Luckily, we
1736− needn't worry much if its kind was eta-reduced away, since using stealKindForType
1739Note [Kind signatures in derived instances]
1574Note [Kind signatures in derived instances]
1740~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1575~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1813,50 +1648,14 @@ things we can do to make instance contexts that work for 80% of use cases:
1813 and perform kind substitution as in the other cases.
1648 and perform kind substitution as in the other cases.
1816−-- Determines the types of a constructor's arguments as well as the last type
1651+checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name
1817−-- parameters (mapped to their encoding/decoding functions), expanding through
1652+ -> Q a -> Q a
1818−-- any type synonyms.
1653+checkExistentialContext jc tvMap ctxt conName q =
1820−-- The type parameters are determined on a constructor-by-constructor basis since
1821−-- they may be refined to be particular types in a GADT.
1822−reifyConTys :: JSONClass
1825− -> Q ([Type], TyVarMap)
1826−reifyConTys jc tpjs conName = do
1827− info <- reify conName
1828− (ctxt, uncTy) <- case info of
1830−#if !(MIN_VERSION_template_haskell(2,11,0))
1833− -> fmap uncurryTy (expandSyn ty)
1834− _ -> error "Must be a data constructor"
1835− let (argTys, [resTy]) = NE.splitAt (NE.length uncTy - 1) uncTy
1836− unapResTy = unapplyTy resTy
1837− -- If one of the last type variables is refined to a particular type
1838− -- (i.e., not truly polymorphic), we mark it with Nothing and filter
1839− -- it out later, since we only apply encoding/decoding functions to
1840− -- arguments of a type that it (1) one of the last type variables,
1841− -- and (2) of a truly polymorphic type.
1842− jArity = arityInt jc
1843− mbTvNames = map varTToNameMaybe $
1844− NE.drop (NE.length unapResTy - jArity) unapResTy
1845− -- We use M.fromList to ensure that if there are any duplicate type
1846− -- variables (as can happen in a GADT), the rightmost type variable gets
1847− -- associated with the show function.
1849− -- See Note [Matching functions with GADT type variables]
1851− . catMaybes -- Drop refined types
1852− $ zipWith (\mbTvName tpj ->
1853− fmap (\tvName -> (tvName, tpj)) mbTvName)
1855− if (any (`predMentionsName` M.keys tvMap) ctxt
1654+ if (any (`predMentionsName` M.keys tvMap) ctxt
1856− || M.size tvMap < jArity)
1655+ || M.size tvMap < arityInt jc)
1857− && not (allowExQuant jc)
1656+ && not (allowExQuant jc)
1858− then existentialContextError conName
1657+ then existentialContextError conName
1859− else return (argTys, tvMap)
1658+ else q
1862Note [Matching functions with GADT type variables]
1661Note [Matching functions with GADT type variables]
@@ -1896,24 +1695,6 @@ Both.
1896-- are the function arguments of types (b -> Value) and ([b] -> Value).
1695-- are the function arguments of types (b -> Value) and ([b] -> Value).
1897type TyVarMap = Map Name (Name, Name)
1696type TyVarMap = Map Name (Name, Name)
1899−-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.
1900−stealKindForType :: TyVarBndr -> Type -> Type
1901−stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)
1902−stealKindForType _ t = t
1904−-- | Extracts the kind from a type variable binder.
1905−tvbKind :: TyVarBndr -> Kind
1906−#if MIN_VERSION_template_haskell(2,8,0)
1907−tvbKind (PlainTV _ ) = StarT
1909−tvbKind (PlainTV _ ) = StarK
1911−tvbKind (KindedTV _ k) = k
1913−tvbToType :: TyVarBndr -> Type
1914−tvbToType (PlainTV n) = VarT n
1915−tvbToType (KindedTV n k) = SigT (VarT n) k
1917-- | Returns True if a Type has kind *.
1698-- | Returns True if a Type has kind *.
1918hasKindStar :: Type -> Bool
1699hasKindStar :: Type -> Bool
1919hasKindStar VarT{} = True
1700hasKindStar VarT{} = True
@@ -1938,27 +1719,6 @@ isStarOrVar _ = False
1938newNameList :: String -> Int -> Q [Name]
1719newNameList :: String -> Int -> Q [Name]
1939newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]
1720newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]
1941−-- Gets all of the type/kind variable names mentioned somewhere in a Type.
1942−tyVarNamesOfType :: Type -> [Name]
1943−tyVarNamesOfType = go
1945− go :: Type -> [Name]
1946− go (AppT t1 t2) = go t1 ++ go t2
1947− go (SigT t _k) = go t
1948−#if MIN_VERSION_template_haskell(2,8,0)
1954−-- | Gets all of the type/kind variable names mentioned somewhere in a Kind.
1955−tyVarNamesOfKind :: Kind -> [Name]
1956−#if MIN_VERSION_template_haskell(2,8,0)
1957−tyVarNamesOfKind = tyVarNamesOfType
1959−tyVarNamesOfKind _ = [] -- There are no kind variables
1962-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
1722-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
1963-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
1723-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
1964-- kind variables.
1724-- kind variables.
@@ -1966,7 +1726,7 @@ hasKindVarChain :: Int -> Type -> Maybe [Name]
1966hasKindVarChain kindArrows t =
1726hasKindVarChain kindArrows t =
1967 let uk = uncurryKind (tyKind t)
1727 let uk = uncurryKind (tyKind t)
1968 in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk
1728 in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk
1969− then Just (concatMap tyVarNamesOfKind uk)
1729+ then Just (concatMap freeVariables uk)
1970 else Nothing
1730 else Nothing
1972-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
1732-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
@@ -1986,17 +1746,6 @@ varTToNameMaybe _ = Nothing
1986varTToName :: Type -> Name
1746varTToName :: Type -> Name
1987varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe
1747varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe
1989−-- | Extracts the name from a constructor.
1990−getConName :: Con -> Name
1991−getConName (NormalC name _) = name
1992−getConName (RecC name _) = name
1993−getConName (InfixC _ name _) = name
1994−getConName (ForallC _ _ con) = getConName con
1995−#if MIN_VERSION_template_haskell(2,11,0)
1996−getConName (GadtC names _ _) = head names
1997−getConName (RecGadtC names _ _) = head names
2000interleave :: [a] -> [a] -> [a]
1749interleave :: [a] -> [a] -> [a]
2001interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
1750interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
2002interleave _ _ = []
1751interleave _ _ = []
@@ -2128,12 +1877,12 @@ createKindChain = go starK
2130-- | Makes a string literal expression from a constructor's name.
1879-- | Makes a string literal expression from a constructor's name.
2131−conNameExp :: Options -> Con -> Q Exp
1880+conNameExp :: Options -> ConstructorInfo -> Q Exp
2132conNameExp opts = litE
1881conNameExp opts = litE
2133 . stringL
1882 . stringL
2134 . constructorTagModifier opts
1883 . constructorTagModifier opts
2135 . nameBase
1884 . nameBase
2136− . getConName
1885+ . constructorName
2138-- | Creates a string literal expression from a record field label.
1887-- | Creates a string literal expression from a record field label.
2139fieldLabelExp :: Options -- ^ Encoding options
1888fieldLabelExp :: Options -- ^ Encoding options
@@ -2178,73 +1927,15 @@ canEtaReduce remaining dropped =
2178-- Expanding type synonyms
1927-- Expanding type synonyms
2179-------------------------------------------------------------------------------
1928-------------------------------------------------------------------------------
2181−-- | Expands all type synonyms in a type. Written by Dan Rosén in the
1930+applySubstitutionKind :: Map Name Kind -> Type -> Type
2182−-- @genifunctors@ package (licensed under BSD3).
2183−expandSyn :: Type -> Q Type
2184−expandSyn (ForallT tvs ctx t) = ForallT tvs ctx <$> expandSyn t
2185−expandSyn t@AppT{} = expandSynApp t []
2186−expandSyn t@ConT{} = expandSynApp t []
2187−expandSyn (SigT t k) = do t' <- expandSyn t
2188− k' <- expandSynKind k
2189− return (SigT t' k')
2190−expandSyn t = return t
2192−expandSynKind :: Kind -> Q Kind
2193−#if MIN_VERSION_template_haskell(2,8,0)
2194−expandSynKind = expandSyn
2196−expandSynKind = return -- There are no kind synonyms to deal with
2199−expandSynApp :: Type -> [Type] -> Q Type
2200−expandSynApp (AppT t1 t2) ts = do
2201− t2' <- expandSyn t2
2202− expandSynApp t1 (t2':ts)
2203−expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts
2204−expandSynApp t@(ConT n) ts = do
2207− TyConI (TySynD _ tvs rhs) ->
2208− let (ts', ts'') = splitAt (length tvs) ts
2209− subs = mkSubst tvs ts'
2210− rhs' = substType subs rhs
2211− in expandSynApp rhs' ts''
2212− _ -> return $ foldl' AppT t ts
2213−expandSynApp t ts = do
2215− return $ foldl' AppT t' ts
2217−type TypeSubst = Map Name Type
2218−type KindSubst = Map Name Kind
2220−mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst
2222− let vs' = map un vs
2224− un (KindedTV v _) = v
2225− in M.fromList $ zip vs' ts
2227−substType :: TypeSubst -> Type -> Type
2228−substType subs (ForallT v c t) = ForallT v c $ substType subs t
2229−substType subs t@(VarT n) = M.findWithDefault t n subs
2230−substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)
2231−substType subs (SigT t k) = SigT (substType subs t)
2232−#if MIN_VERSION_template_haskell(2,8,0)
2239−substKind :: KindSubst -> Type -> Type
2240#if MIN_VERSION_template_haskell(2,8,0)
1931#if MIN_VERSION_template_haskell(2,8,0)
2241−substKind = substType
1932+applySubstitutionKind = applySubstitution
2243−substKind _ t = t -- There are no kind variables!
1934+applySubstitutionKind _ t = t
2246substNameWithKind :: Name -> Kind -> Type -> Type
1937substNameWithKind :: Name -> Kind -> Type -> Type
2247−substNameWithKind n k = substKind (M.singleton n k)
1938+substNameWithKind n k = applySubstitutionKind (M.singleton n k)
2249substNamesWithKindStar :: [Name] -> Type -> Type
1940substNamesWithKindStar :: [Name] -> Type -> Type
2250substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns
1941substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns