@@ -130,7 +130,7 @@ import Data.Foldable (foldr')
130130#if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
131131import Data.List (nub)
132132#endif
133−import Data.List (find, foldl', genericLength , intercalate , intersperse, partition, union)
133+import Data.List (foldl', genericLength , intercalate , intersperse, partition, union)
134134import Data.List.NonEmpty ((<|), NonEmpty((:|)))
135135import Data.Map (Map)
136136import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
@@ -140,7 +140,7 @@ import Language.Haskell.TH hiding (Arity)
140140#else
141141import Language.Haskell.TH
142142#endif
143−import Language.Haskell.TH.Syntax (VarStrictType)
143+import Language.Haskell.TH.Datatype
144144#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))
145145import Language.Haskell.TH.Lib (starK)
146146#endif
@@ -152,8 +152,8 @@ import qualified Data.Aeson as A
152152import qualified Data.Aeson.Encoding.Internal as E
153153import qualified Data.Foldable as F (all)
154154import qualified Data.HashMap.Strict as H (lookup, toList)
155−import qualified Data.List.NonEmpty as NE (drop, length, reverse, splitAt)
156−import qualified Data.Map as M (fromList, findWithDefault, keys, lookup , singleton, size)
155+import qualified Data.List.NonEmpty as NE (length, reverse)
156+import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
157157import qualified Data.Set as Set (empty, insert, member)
158158import qualified Data.Text as T (Text, pack, unpack)
159159import qualified Data.Vector as V (unsafeIndex, null, length, create, fromList)
@@ -322,32 +322,36 @@ consToValue :: JSONClass
322322 -- ^ The ToJSON variant being derived.
323323 -> Options
324324 -- ^ Encoding options.
325− -> [Con]
325+ -> [Type]
326+ -- ^ The types from the data type/data family instance declaration
327+ -> [ConstructorInfo]
326328 -- ^ Constructors for which to generate JSON generating code.
327329 -> Q Exp
328330
329−consToValue _ _ [] = error $ "Data.Aeson.TH.consToValue: "
330− ++ "Not a single constructor given!"
331+consToValue _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "
332+ ++ "Not a single constructor given!"
331333
332−consToValue jc opts cons = do
334+consToValue jc opts vars cons = do
333335 value <- newName "value"
334336 tjs <- newNameList "_tj" $ arityInt jc
335337 tjls <- newNameList "_tjl" $ arityInt jc
336338 let zippedTJs = zip tjs tjls
337339 interleavedTJs = interleave tjs tjls
340+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
341+ tvMap = M.fromList $ zip lastTyVars zippedTJs
338342 lamE (map varP $ interleavedTJs ++ [value]) $
339− caseE (varE value) (matches zippedTJs)
343+ caseE (varE value) (matches tvMap)
340344 where
341− matches tjs = case cons of
345+ matches tvMap = case cons of
342346 -- A single constructor is directly encoded. The constructor itself may be
343347 -- forgotten.
344− [con] | not (tagSingleConstructors opts) -> [argsToValue jc tjs opts False con]
348+ [con] | not (tagSingleConstructors opts) -> [argsToValue jc tvMap opts False con]
345349 _ | allNullaryToStringTag opts && all isNullary cons ->
346350 [ match (conP conName []) (normalB $ conStr opts conName) []
347351 | con <- cons
348− , let conName = getConName con
352+ , let conName = constructorName con
349353 ]
350− | otherwise -> [argsToValue jc tjs opts True con | con <- cons]
354+ | otherwise -> [argsToValue jc tvMap opts True con | con <- cons]
351355
352356conStr :: Options -> Name -> Q Exp
353357conStr opts = appE [|String|] . conTxt opts
@@ -365,42 +369,47 @@ consToEncoding :: JSONClass
365369 -- ^ The ToJSON variant being derived.
366370 -> Options
367371 -- ^ Encoding options.
368− -> [Con]
372+ -> [Type]
373+ -- ^ The types from the data type/data family instance declaration
374+ -> [ConstructorInfo]
369375 -- ^ Constructors for which to generate JSON generating code.
370376 -> Q Exp
371377
372−consToEncoding _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "
373− ++ "Not a single constructor given!"
378+consToEncoding _ _ _ [] = error $ "Data.Aeson.TH.consToEncoding: "
379+ ++ "Not a single constructor given!"
374380
375−consToEncoding jc opts cons = do
381+consToEncoding jc opts vars cons = do
376382 value <- newName "value"
377383 tes <- newNameList "_te" $ arityInt jc
378384 tels <- newNameList "_tel" $ arityInt jc
379385 let zippedTEs = zip tes tels
380386 interleavedTEs = interleave tes tels
387+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
388+ tvMap = M.fromList $ zip lastTyVars zippedTEs
381389 lamE (map varP $ interleavedTEs ++ [value]) $
382− caseE (varE value) (matches zippedTEs)
390+ caseE (varE value) (matches tvMap)
383391 where
384− matches tes = case cons of
392+ matches tvMap = case cons of
385393 -- A single constructor is directly encoded. The constructor itself may be
386394 -- forgotten.
387− [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tes opts False con]
395+ [con] | not (tagSingleConstructors opts) -> [argsToEncoding jc tvMap opts False con]
388396 -- Encode just the name of the constructor of a sum type iff all the
389397 -- constructors are nullary.
390398 _ | allNullaryToStringTag opts && all isNullary cons ->
391399 [ match (conP conName [])
392400 (normalB $ encStr opts conName) []
393401 | con <- cons
394− , let conName = getConName con
402+ , let conName = constructorName con
395403 ]
396− | otherwise -> [argsToEncoding jc tes opts True con | con <- cons]
404+ | otherwise -> [argsToEncoding jc tvMap opts True con | con <- cons]
397405
398406encStr :: Options -> Name -> Q Exp
399407encStr opts = appE [|E.text|] . conTxt opts
400408
401409-- | If constructor is nullary.
402−isNullary :: Con -> Bool
403−isNullary (NormalC _ []) = True
410+isNullary :: ConstructorInfo -> Bool
411+isNullary (ConstructorInfo { constructorVariant = NormalConstructor
412+ , constructorFields = tys }) = null tys
404413isNullary _ = False
405414
406415sumToValue :: Options -> Bool -> Bool -> Name -> Q Exp -> Q Exp
@@ -423,16 +432,19 @@ sumToValue opts multiCons nullary conName exp
423432 | otherwise = exp
424433
425434-- | 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
427436
428437-- Polyadic constructors with special case for unary constructors.
429−argsToValue jc tjs opts multiCons (NormalC conName ts) = do
430− (argTys, tvMap) <- reifyConTys jc tjs conName
431− let len = length ts
438+argsToValue jc tvMap opts multiCons
439+ (ConstructorInfo { constructorName = conName
440+ , constructorVariant = NormalConstructor
441+ , constructorFields = argTys }) = do
442+ argTys' <- mapM resolveTypeSynonyms argTys
443+ let len = length argTys'
432444 args <- newNameList "arg" len
433445 js <- case [ dispatchToJSON jc conName tvMap argTy
434446 `appE` varE arg
435− | (arg, argTy) <- zip args argTys
447+ | (arg, argTy) <- zip args argTys'
436448 ] of
437449 -- Single argument is directly converted.
438450 [e] -> return e
@@ -454,69 +466,77 @@ argsToValue jc tjs opts multiCons (NormalC conName ts) = do
454466 (varE 'V.create `appE`
455467 doE (newMV:stmts++[ret]))
456468 match (conP conName $ map varP args)
457− (normalB $ sumToValue opts multiCons (null ts) conName js)
469+ (normalB $ sumToValue opts multiCons (null argTys') conName js)
458470 []
459471
460472-- Records.
461−argsToValue jc tjs opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
462− (True,True,[(_,st,ty)]) -> argsToValue jc tjs opts multiCons (NormalC conName [(st,ty)])
463− _ -> do
464− (argTys, tvMap) <- reifyConTys jc tjs conName
465− args <- newNameList "arg" $ length ts
466− let exp = [|A.object|] `appE` pairs
467−
468− pairs | omitNothingFields opts = infixApp maybeFields
469− [|(++)|]
470− restFields
471− | otherwise = listE $ map toPair argCons
472−
473− argCons = zip3 args argTys ts
474−
475− maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
476−
477− restFields = listE $ map toPair rest
478−
479− (maybes, rest) = partition isMaybe argCons
480−
481− maybeToPair (arg, argTy, (field, _, _)) =
482− infixApp ([|keyValuePairWith|]
483− `appE` dispatchToJSON jc conName tvMap argTy
484− `appE` toFieldName field)
485− [|(<$>)|]
486− (varE arg)
487−
488− toPair (arg, argTy, (field, _, _)) =
489− [|keyValuePairWith|]
490− `appE` dispatchToJSON jc conName tvMap argTy
491− `appE` toFieldName field
492− `appE` varE arg
473+argsToValue jc tvMap opts multiCons
474+ info@(ConstructorInfo { constructorName = conName
475+ , constructorVariant = RecordConstructor fields
476+ , constructorFields = argTys }) =
477+ case (unwrapUnaryRecords opts, not multiCons, argTys) of
478+ (True,True,[_]) -> argsToValue jc tvMap opts multiCons
479+ (info{constructorVariant = NormalConstructor})
480+ _ -> do
481+ argTys' <- mapM resolveTypeSynonyms argTys
482+ args <- newNameList "arg" $ length argTys'
483+ let exp = [|A.object|] `appE` pairs
484+
485+ pairs | omitNothingFields opts = infixApp maybeFields
486+ [|(++)|]
487+ restFields
488+ | otherwise = listE $ map toPair argCons
489+
490+ argCons = zip3 args argTys' fields
491+
492+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
493+
494+ restFields = listE $ map toPair rest
495+
496+ (maybes, rest) = partition isMaybe argCons
497+
498+ maybeToPair (arg, argTy, field) =
499+ infixApp ([|keyValuePairWith|]
500+ `appE` dispatchToJSON jc conName tvMap argTy
501+ `appE` toFieldName field)
502+ [|(<$>)|]
503+ (varE arg)
504+
505+ toPair (arg, argTy, field) =
506+ [|keyValuePairWith|]
507+ `appE` dispatchToJSON jc conName tvMap argTy
508+ `appE` toFieldName field
509+ `appE` varE arg
493510
494− toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
495−
496− match (conP conName $ map varP args)
497− ( normalB
498− $ if multiCons
499− then case sumEncoding opts of
500− TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
501− TaggedObject{tagFieldName} ->
502− [|A.object|] `appE`
503− -- TODO: Maybe throw an error in case
504− -- tagFieldName overwrites a field in pairs.
505− infixApp (infixApp [|T.pack tagFieldName|]
506− [|(.=)|]
507− (conStr opts conName))
508− [|(:)|]
509− pairs
510− ObjectWithSingleField ->
511− [|A.object|] `appE` listE
512− [ infixApp (conTxt opts conName) [|(.=)|] exp ]
513− UntaggedValue -> exp
514− else exp
515− ) []
511+ toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field
512+
513+ match (conP conName $ map varP args)
514+ ( normalB
515+ $ if multiCons
516+ then case sumEncoding opts of
517+ TwoElemArray -> [|toJSON|] `appE` tupE [conStr opts conName, exp]
518+ TaggedObject{tagFieldName} ->
519+ [|A.object|] `appE`
520+ -- TODO: Maybe throw an error in case
521+ -- tagFieldName overwrites a field in pairs.
522+ infixApp (infixApp [|T.pack tagFieldName|]
523+ [|(.=)|]
524+ (conStr opts conName))
525+ [|(:)|]
526+ pairs
527+ ObjectWithSingleField ->
528+ [|A.object|] `appE` listE
529+ [ infixApp (conTxt opts conName) [|(.=)|] exp ]
530+ UntaggedValue -> exp
531+ else exp
532+ ) []
516533
517534-- Infix constructors.
518−argsToValue jc tjs opts multiCons (InfixC _ conName _) = do
519− ([alTy, arTy], tvMap) <- reifyConTys jc tjs conName
535+argsToValue jc tvMap opts multiCons
536+ (ConstructorInfo { constructorName = conName
537+ , constructorVariant = InfixConstructor
538+ , constructorFields = argTys }) = do
539+ [alTy, arTy] <- mapM resolveTypeSynonyms argTys
520540 al <- newName "argL"
521541 ar <- newName "argR"
522542 match (infixP (varP al) conName (varP ar))
@@ -528,22 +548,10 @@ argsToValue jc tjs opts multiCons (InfixC _ conName _) = do
528548 ]
529549 )
530550 []
531−-- Existentially quantified constructors.
532−argsToValue jc tjs opts multiCons (ForallC _ _ con) =
533− argsToValue jc tjs opts multiCons con
534−
535−#if MIN_VERSION_template_haskell(2,11,0)
536−-- GADTs.
537−argsToValue jc tjs opts multiCons (GadtC conNames ts _) =
538− argsToValue jc tjs opts multiCons $ NormalC (head conNames) ts
539551
540−argsToValue jc tjs opts multiCons (RecGadtC conNames ts _) =
541− argsToValue jc tjs opts multiCons $ RecC (head conNames) ts
542−#endif
543−
544−isMaybe :: (a, b, (c, d, Type)) -> Bool
545−isMaybe (_, _, (_, _, AppT (ConT t) _)) = t == ''Maybe
546−isMaybe _ = False
552+isMaybe :: (a, Type, b) -> Bool
553+isMaybe (_, AppT (ConT t) _, _) = t == ''Maybe
554+isMaybe _ = False
547555
548556(<^>) :: ExpQ -> ExpQ -> ExpQ
549557(<^>) a b = infixApp a [|(E.><)|] b
@@ -583,14 +591,17 @@ sumToEncoding opts multiCons nullary conName exp
583591 | otherwise = exp
584592
585593-- | 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
587595
588596-- Polyadic constructors with special case for unary constructors.
589−argsToEncoding jc tes opts multiCons (NormalC conName ts) = do
590− (argTys, tvMap) <- reifyConTys jc tes conName
591− let len = length ts
597+argsToEncoding jc tvMap opts multiCons
598+ (ConstructorInfo { constructorName = conName
599+ , constructorVariant = NormalConstructor
600+ , constructorFields = argTys }) = do
601+ argTys' <- mapM resolveTypeSynonyms argTys
602+ let len = length argTys'
592603 args <- newNameList "arg" len
593− js <- case zip args argTys of
604+ js <- case zip args argTys' of
594605 -- Nullary constructors are converted to an empty array.
595606 [] -> return [| E.emptyArray_ |]
596607
@@ -604,73 +615,81 @@ argsToEncoding jc tes opts multiCons (NormalC conName ts) = do
604615 | (x,xTy) <- es
605616 ]))
606617 match (conP conName $ map varP args)
607− (normalB $ sumToEncoding opts multiCons (null ts) conName js)
618+ (normalB $ sumToEncoding opts multiCons (null argTys') conName js)
608619 []
609620
610621-- Records.
611−argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecords opts, not multiCons, ts) of
612− (True,True,[(_,st,ty)]) -> argsToEncoding jc tes opts multiCons (NormalC conName [(st,ty)])
613− _ -> do
614− args <- newNameList "arg" $ length ts
615− (argTys, tvMap) <- reifyConTys jc tes conName
616− let exp = object objBody
617−
618− objBody = [|E.econcat|] `appE`
619− ([|intersperse E.comma|] `appE` pairs)
620− pairs | omitNothingFields opts = infixApp maybeFields
621− [|(++)|]
622− restFields
623− | otherwise = listE (map toPair argCons)
624−
625− argCons = zip3 args argTys ts
626−
627− maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
628−
629− restFields = listE (map toPair rest)
630−
631− (maybes, rest) = partition isMaybe argCons
632−
633− maybeToPair (arg, argTy, (field, _, _)) =
634− infixApp
635− (infixApp
636− (infixE
637− (Just $ toFieldName field <^> [|E.colon|])
638− [|(E.><)|]
639− Nothing)
640− [|(.)|]
641− (dispatchToEncoding jc conName tvMap argTy))
642− [|(<$>)|]
643− (varE arg)
644−
645− toPair (arg, argTy, (field, _, _)) =
646− toFieldName field
647− <:> dispatchToEncoding jc conName tvMap argTy
648− `appE` varE arg
649−
650− toFieldName field = [|E.text|] `appE`
651− ([|T.pack|] `appE` fieldLabelExp opts field)
652−
653− match (conP conName $ map varP args)
654− ( normalB
655− $ if multiCons
656− then case sumEncoding opts of
657− TwoElemArray -> array $
658− encStr opts conName <%> exp
659− TaggedObject{tagFieldName} -> object $
660− ([|E.text (T.pack tagFieldName)|] <:>
661− encStr opts conName) <%>
662− objBody
663− ObjectWithSingleField -> object $
664− encStr opts conName <:> exp
665− UntaggedValue -> exp
666− else exp
667− ) []
622+argsToEncoding jc tvMap opts multiCons
623+ info@(ConstructorInfo { constructorName = conName
624+ , constructorVariant = RecordConstructor fields
625+ , constructorFields = argTys }) = do
626+ case (unwrapUnaryRecords opts, not multiCons, argTys) of
627+ (True,True,[_]) -> argsToEncoding jc tvMap opts multiCons
628+ (info{constructorVariant = NormalConstructor})
629+ _ -> do
630+ argTys' <- mapM resolveTypeSynonyms argTys
631+ args <- newNameList "arg" $ length argTys'
632+ let exp = object objBody
633+
634+ objBody = [|E.econcat|] `appE`
635+ ([|intersperse E.comma|] `appE` pairs)
636+ pairs | omitNothingFields opts = infixApp maybeFields
637+ [|(++)|]
638+ restFields
639+ | otherwise = listE (map toPair argCons)
640+
641+ argCons = zip3 args argTys' fields
642+
643+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
644+
645+ restFields = listE (map toPair rest)
646+
647+ (maybes, rest) = partition isMaybe argCons
648+
649+ maybeToPair (arg, argTy, field) =
650+ infixApp
651+ (infixApp
652+ (infixE
653+ (Just $ toFieldName field <^> [|E.colon|])
654+ [|(E.><)|]
655+ Nothing)
656+ [|(.)|]
657+ (dispatchToEncoding jc conName tvMap argTy))
658+ [|(<$>)|]
659+ (varE arg)
660+
661+ toPair (arg, argTy, field) =
662+ toFieldName field
663+ <:> dispatchToEncoding jc conName tvMap argTy
664+ `appE` varE arg
665+
666+ toFieldName field = [|E.text|] `appE`
667+ ([|T.pack|] `appE` fieldLabelExp opts field)
668+
669+ match (conP conName $ map varP args)
670+ ( normalB
671+ $ if multiCons
672+ then case sumEncoding opts of
673+ TwoElemArray -> array $
674+ encStr opts conName <%> exp
675+ TaggedObject{tagFieldName} -> object $
676+ ([|E.text (T.pack tagFieldName)|] <:>
677+ encStr opts conName) <%>
678+ objBody
679+ ObjectWithSingleField -> object $
680+ encStr opts conName <:> exp
681+ UntaggedValue -> exp
682+ else exp
683+ ) []
668684
669685-- Infix constructors.
670−argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do
686+argsToEncoding jc tvMap opts multiCons
687+ (ConstructorInfo { constructorName = conName
688+ , constructorVariant = InfixConstructor
689+ , constructorFields = argTys }) = do
671690 al <- newName "argL"
672691 ar <- newName "argR"
673− ([alTy,arTy], tvMap) <- reifyConTys jc tes conName
692+ [alTy,arTy] <- mapM resolveTypeSynonyms argTys
674693 match (infixP (varP al) conName (varP ar))
675694 ( normalB
676695 $ sumToEncoding opts multiCons False conName
@@ -680,18 +699,6 @@ argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do
680699 ])
681700 )
682701 []
683−-- Existentially quantified constructors.
684−argsToEncoding jc tes opts multiCons (ForallC _ _ con) =
685− argsToEncoding jc tes opts multiCons con
686−
687−#if MIN_VERSION_template_haskell(2,11,0)
688−-- GADTs.
689−argsToEncoding jc tes opts multiCons (GadtC conNames ts _) =
690− argsToEncoding jc tes opts multiCons $ NormalC (head conNames) ts
691−
692−argsToEncoding jc tes opts multiCons (RecGadtC conNames ts _) =
693− argsToEncoding jc tes opts multiCons $ RecC (head conNames) ts
694−#endif
695702
696703--------------------------------------------------------------------------------
697704-- FromJSON
@@ -775,33 +782,41 @@ consFromJSON :: JSONClass
775782 -- ^ Name of the type to which the constructors belong.
776783 -> Options
777784 -- ^ Encoding options
778− -> [Con]
785+ -> [Type]
786+ -- ^ The types from the data type/data family instance declaration
787+ -> [ConstructorInfo]
779788 -- ^ Constructors for which to generate JSON parsing code.
780789 -> Q Exp
781790
782−consFromJSON _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
783− ++ "Not a single constructor given!"
791+consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
792+ ++ "Not a single constructor given!"
784793
785−consFromJSON jc tName opts cons = do
794+consFromJSON jc tName opts vars cons = do
786795 value <- newName "value"
787796 pjs <- newNameList "_pj" $ arityInt jc
788797 pjls <- newNameList "_pjl" $ arityInt jc
789798 let zippedPJs = zip pjs pjls
790799 interleavedPJs = interleave pjs pjls
791− lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value zippedPJs
800+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
801+ tvMap = M.fromList $ zip lastTyVars zippedPJs
802+ lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap
792803
793804 where
794− lamExpr value pjs = case cons of
805+ checkExi tvMap con = checkExistentialContext jc tvMap
806+ (constructorContext con)
807+ (constructorName con)
808+
809+ lamExpr value tvMap = case cons of
795810 [con]
796811 | not (tagSingleConstructors opts)
797− -> parseArgs jc pjs tName opts con (Right value)
812+ -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)
798813 _ | sumEncoding opts == UntaggedValue
799− -> parseUntaggedValue pjs cons value
814+ -> parseUntaggedValue tvMap cons value
800815 | otherwise
801816 -> caseE (varE value) $
802817 if allNullaryToStringTag opts && all isNullary cons
803818 then allNullaryMatches
804− else mixedMatches pjs
819+ else mixedMatches tvMap
805820
806821 allNullaryMatches =
807822 [ do txt <- newName "txt"
@@ -815,7 +830,7 @@ consFromJSON jc tName opts cons = do
815830 )
816831 ([|pure|] `appE` conE conName)
817832 | con <- cons
818− , let conName = getConName con
833+ , let conName = constructorName con
819834 ]
820835 ++
821836 [ liftM2 (,)
@@ -836,13 +851,13 @@ consFromJSON jc tName opts cons = do
836851 []
837852 ]
838853
839− mixedMatches pjs =
854+ mixedMatches tvMap =
840855 case sumEncoding opts of
841856 TaggedObject {tagFieldName, contentsFieldName} ->
842− parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName
857+ parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
843858 UntaggedValue -> error "UntaggedValue: Should be handled already"
844859 ObjectWithSingleField ->
845− parseObject $ parseObjectWithSingleField pjs
860+ parseObject $ parseObjectWithSingleField tvMap
846861 TwoElemArray ->
847862 [ do arr <- newName "array"
848863 match (conP 'Array [varP arr])
@@ -850,7 +865,7 @@ consFromJSON jc tName opts cons = do
850865 [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
851866 [|(==)|]
852867 (litE $ integerL 2))
853− (parse2ElemArray pjs arr)
868+ (parse2ElemArray tvMap arr)
854869 , liftM2 (,) (normalG [|otherwise|])
855870 ([|not2ElemArray|]
856871 `appE` litE (stringL $ show tName)
@@ -881,20 +896,24 @@ consFromJSON jc tName opts cons = do
881896 []
882897 ]
883898
884− parseTaggedObject pjs typFieldName valFieldName obj = do
899+ parseTaggedObject tvMap typFieldName valFieldName obj = do
885900 conKey <- newName "conKey"
886901 doE [ bindS (varP conKey)
887902 (infixApp (varE obj)
888903 [|(.:)|]
889904 ([|T.pack|] `appE` stringE typFieldName))
890− , noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
905+ , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
891906 ]
892907
893− parseUntaggedValue pjs cons' conVal =
908+ parseUntaggedValue tvMap cons' conVal =
894909 foldr1 (\e e' -> infixApp e [|(<|>)|] e')
895− (map (\x -> parseValue pjs x conVal) cons')
910+ (map (\x -> parseValue tvMap x conVal) cons')
896911
897− parseValue _pjs (NormalC conName []) conVal = do
912+ parseValue _tvMap
913+ (ConstructorInfo { constructorName = conName
914+ , constructorVariant = NormalConstructor
915+ , constructorFields = [] })
916+ conVal = do
898917 str <- newName "str"
899918 caseE (varE conVal)
900919 [ match (conP 'String [varP str])
@@ -907,11 +926,11 @@ consFromJSON jc tName opts cons = do
907926 []
908927 , matchFailed tName conName "String"
909928 ]
910− parseValue pjs con conVal =
911− parseArgs jc pjs tName opts con (Right conVal)
929+ parseValue tvMap con conVal =
930+ checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)
912931
913932
914− parse2ElemArray pjs arr = do
933+ parse2ElemArray tvMap arr = do
915934 conKey <- newName "conKey"
916935 conVal <- newName "conVal"
917936 let letIx n ix =
@@ -926,7 +945,7 @@ consFromJSON jc tName opts cons = do
926945 (caseE (varE conKey)
927946 [ do txt <- newName "txt"
928947 match (conP 'String [varP txt])
929− (normalB $ parseContents pjs
948+ (normalB $ parseContents tvMap
930949 txt
931950 (Right conVal)
932951 'conNotFoundFail2ElemArray
@@ -943,12 +962,12 @@ consFromJSON jc tName opts cons = do
943962 ]
944963 )
945964
946− parseObjectWithSingleField pjs obj = do
965+ parseObjectWithSingleField tvMap obj = do
947966 conKey <- newName "conKey"
948967 conVal <- newName "conVal"
949968 caseE ([e|H.toList|] `appE` varE obj)
950969 [ match (listP [tupP [varP conKey, varP conVal]])
951− (normalB $ parseContents pjs conKey (Right conVal) 'conNotFoundFailObjectSingleField)
970+ (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField)
952971 []
953972 , do other <- newName "other"
954973 match (varP other)
@@ -959,7 +978,7 @@ consFromJSON jc tName opts cons = do
959978 []
960979 ]
961980
962− parseContents pjs conKey contents errorFun =
981+ parseContents tvMap conKey contents errorFun =
963982 caseE (varE conKey)
964983 [ match wildP
965984 ( guardedB $
@@ -967,7 +986,8 @@ consFromJSON jc tName opts cons = do
967986 [|(==)|]
968987 ([|T.pack|] `appE`
969988 conNameExp opts con)
970− e <- parseArgs jc pjs tName opts con contents
989+ e <- checkExi tvMap con $
990+ parseArgs jc tvMap tName opts con contents
971991 return (g, e)
972992 | con <- cons
973993 ]
@@ -980,7 +1000,7 @@ consFromJSON jc tName opts cons = do
9801000 . stringL
9811001 . constructorTagModifier opts
9821002 . nameBase
983− . getConName
1003+ . constructorName
9841004 ) cons
9851005 )
9861006 `appE` ([|T.unpack|] `appE` varE conKey)
@@ -1029,10 +1049,10 @@ parseRecord :: JSONClass
10291049 -> Options
10301050 -> Name
10311051 -> Name
1032− -> [VarStrictType]
1052+ -> [Name]
10331053 -> Name
10341054 -> ExpQ
1035−parseRecord jc tvMap argTys opts tName conName ts obj =
1055+parseRecord jc tvMap argTys opts tName conName fields obj =
10361056 foldl' (\a b -> infixApp a [|(<*>)|] b)
10371057 (infixApp (conE conName) [|(<$>)|] x)
10381058 xs
@@ -1044,7 +1064,7 @@ parseRecord jc tvMap argTys opts tName conName ts obj =
10441064 `appE` varE obj
10451065 `appE` ( [|T.pack|] `appE` fieldLabelExp opts field
10461066 )
1047− | ((field, _, _), argTy) <- zip ts argTys
1067+ | (field, argTy) <- zip fields argTys
10481068 ]
10491069
10501070getValField :: Name -> String -> [MatchQ] -> Q Exp
@@ -1063,67 +1083,82 @@ matchCases (Right valName) = caseE (varE valName)
10631083
10641084-- | Generates code to parse the JSON encoding of a single constructor.
10651085parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
1066− -> [(Name, Name)] -- ^ The names of the encoding/decoding function arguments.
1086+ -> TyVarMap -- ^ Maps the last type variables to their decoding
1087+ -- function arguments.
10671088 -> Name -- ^ Name of the type to which the constructor belongs.
10681089 -> Options -- ^ Encoding options.
1069− -> Con -- ^ Constructor for which to generate JSON parsing code.
1090+ -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.
10701091 -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
10711092 -- Right valName
10721093 -> Q Exp
10731094-- Nullary constructors.
1074−parseArgs jc pjs _ _ (NormalC conName []) (Left _) = do
1075− ([], _) <- reifyConTys jc pjs conName
1076− [|pure|] `appE` conE conName
1077−parseArgs jc pjs tName _ (NormalC conName []) (Right valName) = do
1078− ([], _) <- reifyConTys jc pjs conName
1079− caseE (varE valName) $ parseNullaryMatches tName conName
1095+parseArgs _ _ _ _
1096+ (ConstructorInfo { constructorName = conName
1097+ , constructorVariant = NormalConstructor
1098+ , constructorFields = [] })
1099+ (Left _) =
1100+ [|pure|] `appE` conE conName
1101+parseArgs _ _ tName _
1102+ (ConstructorInfo { constructorName = conName
1103+ , constructorVariant = NormalConstructor
1104+ , constructorFields = [] })
1105+ (Right valName) =
1106+ caseE (varE valName) $ parseNullaryMatches tName conName
10801107
10811108-- Unary constructors.
1082−parseArgs jc pjs _ _ (NormalC conName [_]) contents = do
1083− ([argTy], tvMap) <- reifyConTys jc pjs conName
1084− matchCases contents $ parseUnaryMatches jc tvMap argTy conName
1109+parseArgs jc tvMap _ _
1110+ (ConstructorInfo { constructorName = conName
1111+ , constructorVariant = NormalConstructor
1112+ , constructorFields = [argTy] })
1113+ contents = do
1114+ argTy' <- resolveTypeSynonyms argTy
1115+ matchCases contents $ parseUnaryMatches jc tvMap argTy' conName
10851116
10861117-- Polyadic constructors.
1087−parseArgs jc pjs tName _ (NormalC conName ts) contents = do
1088− (argTys, tvMap) <- reifyConTys jc pjs conName
1089− let len = genericLength ts
1090− matchCases contents $ parseProduct jc tvMap argTys tName conName len
1118+parseArgs jc tvMap tName _
1119+ (ConstructorInfo { constructorName = conName
1120+ , constructorVariant = NormalConstructor
1121+ , constructorFields = argTys })
1122+ contents = do
1123+ argTys' <- mapM resolveTypeSynonyms argTys
1124+ let len = genericLength argTys'
1125+ matchCases contents $ parseProduct jc tvMap argTys' tName conName len
10911126
10921127-- Records.
1093−parseArgs jc pjs tName opts (RecC conName ts) (Left (_, obj)) = do
1094− (argTys, tvMap) <- reifyConTys jc pjs conName
1095− parseRecord jc tvMap argTys opts tName conName ts obj
1096−parseArgs jc pjs tName opts (RecC conName ts) (Right valName) = case (unwrapUnaryRecords opts,ts) of
1097− (True,[(_,st,ty)])-> parseArgs jc pjs tName opts (NormalC conName [(st,ty)]) (Right valName)
1098− _ -> do
1099− obj <- newName "recObj"
1100− (argTys, tvMap) <- reifyConTys jc pjs conName
1101− caseE (varE valName)
1102− [ match (conP 'Object [varP obj]) (normalB $
1103− parseRecord jc tvMap argTys opts tName conName ts obj) []
1104− , matchFailed tName conName "Object"
1105− ]
1128+parseArgs jc tvMap tName opts
1129+ (ConstructorInfo { constructorName = conName
1130+ , constructorVariant = RecordConstructor fields
1131+ , constructorFields = argTys })
1132+ (Left (_, obj)) = do
1133+ argTys' <- mapM resolveTypeSynonyms argTys
1134+ parseRecord jc tvMap argTys' opts tName conName fields obj
1135+parseArgs jc tvMap tName opts
1136+ info@(ConstructorInfo { constructorName = conName
1137+ , constructorVariant = RecordConstructor fields
1138+ , constructorFields = argTys })
1139+ (Right valName) =
1140+ case (unwrapUnaryRecords opts,argTys) of
1141+ (True,[_])-> parseArgs jc tvMap tName opts
1142+ (info{constructorVariant = NormalConstructor})
1143+ (Right valName)
1144+ _ -> do
1145+ obj <- newName "recObj"
1146+ argTys' <- mapM resolveTypeSynonyms argTys
1147+ caseE (varE valName)
1148+ [ match (conP 'Object [varP obj]) (normalB $
1149+ parseRecord jc tvMap argTys' opts tName conName fields obj) []
1150+ , matchFailed tName conName "Object"
1151+ ]
11061152
11071153-- Infix constructors. Apart from syntax these are the same as
11081154-- polyadic constructors.
1109−parseArgs jc pjs tName _ (InfixC _ conName _) contents = do
1110− (argTys, tvMap) <- reifyConTys jc pjs conName
1111− matchCases contents $ parseProduct jc tvMap argTys tName conName 2
1112−
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
1117−
1118−#if MIN_VERSION_template_haskell(2,11,0)
1119−-- GADTs. We ignore the refined return type and proceed as if it were a
1120−-- NormalC or RecC.
1121−parseArgs jc pjs tName opts (GadtC conNames ts _) contents =
1122− parseArgs jc pjs tName opts (NormalC (head conNames) ts) contents
1123−
1124−parseArgs jc pjs tName opts (RecGadtC conNames ts _) contents =
1125− parseArgs jc pjs tName opts (RecC (head conNames) ts) contents
1126−#endif
1155+parseArgs jc tvMap tName _
1156+ (ConstructorInfo { constructorName = conName
1157+ , constructorVariant = InfixConstructor
1158+ , constructorFields = argTys })
1159+ contents = do
1160+ argTys' <- mapM resolveTypeSynonyms argTys
1161+ matchCases contents $ parseProduct jc tvMap argTys' tName conName 2
11271162
11281163-- | Generates code to parse the JSON encoding of an n-ary
11291164-- constructor.
@@ -1278,7 +1313,8 @@ deriveJSONBoth dtj dfj opts name =
12781313 liftM2 (++) (dtj opts name) (dfj opts name)
12791314
12801315-- | Functionality common to @deriveToJSON(1)(2)@ and @deriveFromJSON(1)(2)@.
1281−deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]
1316+deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]
1317+ -> [ConstructorInfo] -> Q Exp)]
12821318 -- ^ The class methods and the functions which derive them.
12831319 -> JSONClass
12841320 -- ^ The class for which to generate an instance.
@@ -1288,27 +1324,30 @@ deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]
12881324 -- ^ Name of the type for which to generate a class instance
12891325 -- declaration.
12901326 -> Q [Dec]
1291−deriveJSONClass consFuns jc opts name =
1292− withType name $ \name' ctxt tvbs cons mbTys ->
1293− (:[]) <$> fromCons name' ctxt tvbs cons mbTys
1294− where
1295− fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
1296− fromCons name' ctxt tvbs cons mbTys = do
1327+deriveJSONClass consFuns jc opts name = do
1328+ info <- reifyDatatype name
1329+ case info of
1330+ DatatypeInfo { datatypeContext = ctxt
1331+ , datatypeName = parentName
1332+ , datatypeVars = vars
1333+ , datatypeVariant = variant
1334+ , datatypeCons = cons
1335+ } -> do
12971336 (instanceCxt, instanceType)
1298− <- buildTypeInstance name' jc ctxt tvbs mbTys
1299− instanceD (return instanceCxt)
1300− (return instanceType)
1301− (methodDecs name' cons)
1302−
1303− methodDecs :: Name -> [Con] -> [Q Dec]
1304− methodDecs name' cons = flip map consFuns $ \(jf, jfMaker) ->
1337+ <- buildTypeInstance parentName jc ctxt vars variant
1338+ (:[]) <$> instanceD (return instanceCxt)
1339+ (return instanceType)
1340+ (methodDecs parentName vars cons)
1341+ where
1342+ methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
1343+ methodDecs parentName vars cons = flip map consFuns $ \(jf, jfMaker) ->
13051344 funD (jsonFunValName jf (arity jc))
13061345 [ clause []
1307− (normalB $ jfMaker jc name' opts cons)
1346+ (normalB $ jfMaker jc parentName opts vars cons)
13081347 []
13091348 ]
13101349
1311−mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)
1350+mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
13121351 -- ^ The function which derives the expression.
13131352 -> JSONClass
13141353 -- ^ Which class's method is being derived.
@@ -1317,15 +1356,20 @@ mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)
13171356 -> Name
13181357 -- ^ Name of the encoded type.
13191358 -> Q Exp
1320−mkFunCommon consFun jc opts name = withType name fromCons
1321− where
1322− fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
1323− fromCons name' ctxt tvbs cons mbTys = do
1324− -- We force buildTypeInstance here since it performs some checks for whether
1325− -- or not the provided datatype's kind matches the derived method's
1326− -- typeclass, and produces errors if it can't.
1327− !_ <- buildTypeInstance name' jc ctxt tvbs mbTys
1328− consFun jc name' opts cons
1359+mkFunCommon consFun jc opts name = do
1360+ info <- reifyDatatype name
1361+ case info of
1362+ DatatypeInfo { datatypeContext = ctxt
1363+ , datatypeName = parentName
1364+ , datatypeVars = vars
1365+ , datatypeVariant = variant
1366+ , datatypeCons = cons
1367+ } -> do
1368+ -- We force buildTypeInstance here since it performs some checks for whether
1369+ -- or not the provided datatype's kind matches the derived method's
1370+ -- typeclass, and produces errors if it can't.
1371+ !_ <- buildTypeInstance parentName jc ctxt vars variant
1372+ consFun jc parentName opts vars cons
13291373
13301374dispatchFunByType :: JSONClass
13311375 -> JSONFun
@@ -1380,190 +1424,24 @@ dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False
13801424-- Utility functions
13811425--------------------------------------------------------------------------------
13821426
1383−-- | Boilerplate for top level splices.
1384−--
1385−-- The given 'Name' must meet one of two criteria:
1386−--
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.
1389−
1390−-- Any other value will result in an exception.
1391−withType :: Name
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'.
1399− -> Q a
1400− -- ^ Resulting value in the 'Q'uasi monad.
1401−withType name f = do
1402− info <- reify name
1403− case info of
1404− TyConI dec ->
1405− case dec of
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
1409−#else
1410− DataD ctxt _ tvbs cons _ -> f name ctxt tvbs cons Nothing
1411− NewtypeD ctxt _ tvbs con _ -> f name ctxt tvbs [con] Nothing
1412−#endif
1413− other -> fail $ ns ++ "Unsupported type: " ++ show other
1414−#if MIN_VERSION_template_haskell(2,11,0)
1415− DataConI _ _ parentName -> do
1416−#else
1417− DataConI _ _ parentName _ -> do
1418−#endif
1419− parentInfo <- reify parentName
1420− case parentInfo of
1421−#if MIN_VERSION_template_haskell(2,11,0)
1422− FamilyI (DataFamilyD _ tvbs _) decs ->
1423−#else
1424− FamilyI (FamilyD DataFam _ tvbs _) decs ->
1425−#endif
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
1430−#else
1431− DataInstD _ _ _ cons _ -> any ((name ==) . getConName) cons
1432− NewtypeInstD _ _ _ con _ -> name == getConName con
1433−#endif
1434− _ -> error $ ns ++ "Must be a data or newtype instance."
1435− in case instDec of
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
1439−#else
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
1442−#endif
1443− _ -> fail $ ns ++
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{} _ ->
1449−#else
1450− FamilyI (FamilyD DataFam _ _ _) _ ->
1451−#endif
1452− fail $ ns ++
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."
1456− where
1457− ns :: String
1458− ns = "Data.Aeson.TH.withType: "
1459−
1460−-- | Infer the context and instance head needed for a FromJSON or ToJSON instance.
1427+-- For the given Types, generate an instance context and head.
14611428buildTypeInstance :: Name
14621429 -- ^ The type constructor or data family name
14631430 -> JSONClass
14641431 -- ^ The typeclass to derive
14651432 -> Cxt
14661433 -- ^ The datatype context
1467− -> [TyVarBndr]
1468− -- ^ The type variables from the data type/data family declaration
1469− -> Maybe [Type]
1470− -- ^ 'Just' the types used to instantiate a data family instance,
1471− -- or 'Nothing' if it's a plain data type
1434+ -> [Type]
1435+ -- ^ The types to instantiate the instance with
1436+ -> DatatypeVariant
1437+ -- ^ Are we dealing with a data family instance or not
14721438 -> 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
1480−--
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
1487−#else
1488− let kindVarNames :: [Name]
1489− kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs
1490−
1491− numKindVars :: Int
1492− numKindVars = length kindVarNames
1493−
1494− givenKinds, givenKinds' :: [Kind]
1495− givenTys :: [Type]
1496− (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds
1497− givenKinds' = map sanitizeStars givenKinds
1498−
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
1503− sanitizeStars = go
1504− where
1505− go :: 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
1509− go t = t
1510−
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" "*"
1515−
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)
1521−
1522− let xTys :: [Type]
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).
1528−
1529− substNamesWithKinds :: [(Name, Kind)] -> Type -> Type
1530− substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks
1531−
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.
1536− instTys :: [Type]
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)
1546−#endif
1547− buildTypeInstanceFromTys dataFamName jc dataCxt instTys True
1548−
1549−-- For the given Types, generate an instance context and head.
1550−buildTypeInstanceFromTys :: Name
1551− -- ^ The type constructor or data family name
1552− -> JSONClass
1553− -- ^ The typeclass to derive
1554− -> Cxt
1555− -- ^ The datatype context
1556− -> [Type]
1557− -- ^ The types to instantiate the instance with
1558− -> Bool
1559− -- ^ True if it's a data family, False otherwise
1560− -> Q (Cxt, Type)
1561−buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
1439+buildTypeInstance tyConName jc dataCxt varTysOrig variant = do
15621440 -- Make sure to expand through type/kind synonyms! Otherwise, the
15631441 -- eta-reduction check might get tripped up over type variables in a
15641442 -- synonym that are actually dropped.
15651443 -- (See GHC Trac #11416 for a scenario where this actually happened.)
1566− varTysExp <- mapM expandSyn varTysOrig
1444+ varTysExp <- mapM resolveTypeSynonyms varTysOrig
15671445
15681446 let remainingLength :: Int
15691447 remainingLength = length varTysOrig - arityInt jc
@@ -1593,7 +1471,7 @@ buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
15931471 -- All of the type variables mentioned in the dropped types
15941472 -- (post-synonym expansion)
15951473 droppedTyVarNames :: [Name]
1596− droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst
1474+ droppedTyVarNames = freeVariables droppedTysExpSubst
15971475
15981476 -- If any of the dropped types were polykinded, ensure that they are of kind *
15991477 -- after substituting * for the dropped kind variables. If not, throw an error.
@@ -1634,6 +1512,13 @@ buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
16341512 map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))
16351513 $ take remainingLength varTysOrig
16361514
1515+ isDataFamily :: Bool
1516+ isDataFamily = case variant of
1517+ Datatype -> False
1518+ Newtype -> False
1519+ DataInstance -> True
1520+ NewtypeInstance -> True
1521+
16371522 remainingTysOrigSubst' :: [Type]
16381523 -- See Note [Kind signatures in derived instances] for an explanation
16391524 -- of the isDataFamily check.
@@ -1687,55 +1572,6 @@ deriveConstraint jc t
16871572 jcConstraint = jsonClassName . JSONClass (direction jc)
16881573
16891574{-
1690−Note [Polykinded data families in Template Haskell]
1691−~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1692−
1693−In order to come up with the correct instance context and head for an instance, e.g.,
1694−
1695− instance C a => C (Data a) where ...
1696−
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.
1700−
1701−Doing the same for data families proves to be much harder for three reasons:
1702−
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:
1705−
1706− data family Fam (f :: * -> *) (a :: *)
1707− data instance Fam f a
1708−
1709− Then if we use TH's reify function, it would tell us the TyVarBndrs of the
1710− data family declaration are:
1711−
1712− [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]
1713−
1714− and the instantiated types of the data family instance are:
1715−
1716− [VarT f1,VarT a1]
1717−
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.
1733−
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
1737− will get it back.
1738−
17391575Note [Kind signatures in derived instances]
17401576~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
17411577
@@ -1813,50 +1649,14 @@ things we can do to make instance contexts that work for 80% of use cases:
18131649 and perform kind substitution as in the other cases.
18141650-}
18151651
1816−-- Determines the types of a constructor's arguments as well as the last type
1817−-- parameters (mapped to their encoding/decoding functions), expanding through
1818−-- any type synonyms.
1819−--
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
1823− -> [(Name, Name)]
1824− -> Name
1825− -> Q ([Type], TyVarMap)
1826−reifyConTys jc tpjs conName = do
1827− info <- reify conName
1828− (ctxt, uncTy) <- case info of
1829− DataConI _ ty _
1830−#if !(MIN_VERSION_template_haskell(2,11,0))
1831− _
1832−#endif
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.
1848− --
1849− -- See Note [Matching functions with GADT type variables]
1850− tvMap = M.fromList
1851− . catMaybes -- Drop refined types
1852− $ zipWith (\mbTvName tpj ->
1853− fmap (\tvName -> (tvName, tpj)) mbTvName)
1854− mbTvNames tpjs
1855− if (any (`predMentionsName` M.keys tvMap) ctxt
1856− || M.size tvMap < jArity)
1857− && not (allowExQuant jc)
1858− then existentialContextError conName
1859− else return (argTys, tvMap)
1652+checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name
1653+ -> Q a -> Q a
1654+checkExistentialContext jc tvMap ctxt conName q =
1655+ if (any (`predMentionsName` M.keys tvMap) ctxt
1656+ || M.size tvMap < arityInt jc)
1657+ && not (allowExQuant jc)
1658+ then existentialContextError conName
1659+ else q
18601660
18611661{-
18621662Note [Matching functions with GADT type variables]
@@ -1896,24 +1696,6 @@ Both.
18961696-- are the function arguments of types (b -> Value) and ([b] -> Value).
18971697type TyVarMap = Map Name (Name, Name)
18981698
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
1903−
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
1908−#else
1909−tvbKind (PlainTV _ ) = StarK
1910−#endif
1911−tvbKind (KindedTV _ k) = k
1912−
1913−tvbToType :: TyVarBndr -> Type
1914−tvbToType (PlainTV n) = VarT n
1915−tvbToType (KindedTV n k) = SigT (VarT n) k
1916−
19171699-- | Returns True if a Type has kind *.
19181700hasKindStar :: Type -> Bool
19191701hasKindStar VarT{} = True
@@ -1938,27 +1720,6 @@ isStarOrVar _ = False
19381720newNameList :: String -> Int -> Q [Name]
19391721newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]
19401722
1941−-- Gets all of the type/kind variable names mentioned somewhere in a Type.
1942−tyVarNamesOfType :: Type -> [Name]
1943−tyVarNamesOfType = go
1944− where
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)
1949− ++ go _k
1950−#endif
1951− go (VarT n) = [n]
1952− go _ = []
1953−
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
1958−#else
1959−tyVarNamesOfKind _ = [] -- There are no kind variables
1960−#endif
1961−
19621723-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
19631724-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
19641725-- kind variables.
@@ -1966,7 +1727,7 @@ hasKindVarChain :: Int -> Type -> Maybe [Name]
19661727hasKindVarChain kindArrows t =
19671728 let uk = uncurryKind (tyKind t)
19681729 in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk
1969− then Just (concatMap tyVarNamesOfKind uk)
1730+ then Just (concatMap freeVariables uk)
19701731 else Nothing
19711732
19721733-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
@@ -1986,17 +1747,6 @@ varTToNameMaybe _ = Nothing
19861747varTToName :: Type -> Name
19871748varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe
19881749
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
1998−#endif
1999−
20001750interleave :: [a] -> [a] -> [a]
20011751interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
20021752interleave _ _ = []
@@ -2128,12 +1878,12 @@ createKindChain = go starK
21281878#endif
21291879
21301880-- | Makes a string literal expression from a constructor's name.
2131−conNameExp :: Options -> Con -> Q Exp
1881+conNameExp :: Options -> ConstructorInfo -> Q Exp
21321882conNameExp opts = litE
21331883 . stringL
21341884 . constructorTagModifier opts
21351885 . nameBase
2136− . getConName
1886+ . constructorName
21371887
21381888-- | Creates a string literal expression from a record field label.
21391889fieldLabelExp :: Options -- ^ Encoding options
@@ -2178,73 +1928,15 @@ canEtaReduce remaining dropped =
21781928-- Expanding type synonyms
21791929-------------------------------------------------------------------------------
21801930
2181−-- | Expands all type synonyms in a type. Written by Dan Rosén in the
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
2191−
2192−expandSynKind :: Kind -> Q Kind
2193−#if MIN_VERSION_template_haskell(2,8,0)
2194−expandSynKind = expandSyn
2195−#else
2196−expandSynKind = return -- There are no kind synonyms to deal with
2197−#endif
2198−
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
2205− info <- reify n
2206− case info of
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
2214− t' <- expandSyn t
2215− return $ foldl' AppT t' ts
2216−
2217−type TypeSubst = Map Name Type
2218−type KindSubst = Map Name Kind
2219−
2220−mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst
2221−mkSubst vs ts =
2222− let vs' = map un vs
2223− un (PlainTV v) = v
2224− un (KindedTV v _) = v
2225− in M.fromList $ zip vs' ts
2226−
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)
2233− (substType subs k)
2234−#else
2235− k
2236−#endif
2237−substType _ t = t
2238−
2239−substKind :: KindSubst -> Type -> Type
1931+applySubstitutionKind :: Map Name Kind -> Type -> Type
22401932#if MIN_VERSION_template_haskell(2,8,0)
2241−substKind = substType
1933+applySubstitutionKind = applySubstitution
22421934#else
2243−substKind _ t = t -- There are no kind variables!
1935+applySubstitutionKind _ t = t
22441936#endif
22451937
22461938substNameWithKind :: Name -> Kind -> Type -> Type
2247−substNameWithKind n k = substKind (M.singleton n k)
1939+substNameWithKind n k = applySubstitutionKind (M.singleton n k)
22481940
22491941substNamesWithKindStar :: [Name] -> Type -> Type
22501942substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns