@@ -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,16 @@ 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
592− args <- newNameList "arg" len
593− js <- case zip args argTys of
597+argsToEncoding jc tvMap opts multiCons
598+ ConstructorInfo { constructorName = conName
599+ , constructorVariant = NormalConstructor
600+ , constructorFields = argTys } = do
601+ argTys' <- mapM resolveTypeSynonyms argTys
602+ args <- newNameList "arg" $ length argTys'
603+ js <- case zip args argTys' of
594604 -- Nullary constructors are converted to an empty array.
595605 [] -> return [| E.emptyArray_ |]
596606
@@ -604,73 +614,81 @@ argsToEncoding jc tes opts multiCons (NormalC conName ts) = do
604614 | (x,xTy) <- es
605615 ]))
606616 match (conP conName $ map varP args)
607− (normalB $ sumToEncoding opts multiCons (null ts) conName js)
617+ (normalB $ sumToEncoding opts multiCons (null argTys') conName js)
608618 []
609619
610620-- 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− ) []
621+argsToEncoding jc tvMap opts multiCons
622+ info@ConstructorInfo { constructorName = conName
623+ , constructorVariant = RecordConstructor fields
624+ , constructorFields = argTys } =
625+ case (unwrapUnaryRecords opts, not multiCons, argTys) of
626+ (True,True,[_]) -> argsToEncoding jc tvMap opts multiCons
627+ (info{constructorVariant = NormalConstructor})
628+ _ -> do
629+ argTys' <- mapM resolveTypeSynonyms argTys
630+ args <- newNameList "arg" $ length argTys'
631+ let exp = object objBody
632+
633+ objBody = [|E.econcat|] `appE`
634+ ([|intersperse E.comma|] `appE` pairs)
635+ pairs | omitNothingFields opts = infixApp maybeFields
636+ [|(++)|]
637+ restFields
638+ | otherwise = listE (map toPair argCons)
639+
640+ argCons = zip3 args argTys' fields
641+
642+ maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes)
643+
644+ restFields = listE (map toPair rest)
645+
646+ (maybes, rest) = partition isMaybe argCons
647+
648+ maybeToPair (arg, argTy, field) =
649+ infixApp
650+ (infixApp
651+ (infixE
652+ (Just $ toFieldName field <^> [|E.colon|])
653+ [|(E.><)|]
654+ Nothing)
655+ [|(.)|]
656+ (dispatchToEncoding jc conName tvMap argTy))
657+ [|(<$>)|]
658+ (varE arg)
659+
660+ toPair (arg, argTy, field) =
661+ toFieldName field
662+ <:> dispatchToEncoding jc conName tvMap argTy
663+ `appE` varE arg
664+
665+ toFieldName field = [|E.text|] `appE`
666+ ([|T.pack|] `appE` fieldLabelExp opts field)
667+
668+ match (conP conName $ map varP args)
669+ ( normalB
670+ $ if multiCons
671+ then case sumEncoding opts of
672+ TwoElemArray -> array $
673+ encStr opts conName <%> exp
674+ TaggedObject{tagFieldName} -> object $
675+ ([|E.text (T.pack tagFieldName)|] <:>
676+ encStr opts conName) <%>
677+ objBody
678+ ObjectWithSingleField -> object $
679+ encStr opts conName <:> exp
680+ UntaggedValue -> exp
681+ else exp
682+ ) []
668683
669684-- 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
671689 al <- newName "argL"
672690 ar <- newName "argR"
673− ([alTy,arTy], tvMap) <- reifyConTys jc tes conName
691+ [alTy,arTy] <- mapM resolveTypeSynonyms argTys
674692 match (infixP (varP al) conName (varP ar))
675693 ( normalB
676694 $ sumToEncoding opts multiCons False conName
@@ -680,18 +698,6 @@ argsToEncoding jc tes opts multiCons (InfixC _ conName _) = do
680698 ])
681699 )
682700 []
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
695701
696702--------------------------------------------------------------------------------
697703-- FromJSON
@@ -775,33 +781,41 @@ consFromJSON :: JSONClass
775781 -- ^ Name of the type to which the constructors belong.
776782 -> Options
777783 -- ^ Encoding options
778− -> [Con]
784+ -> [Type]
785+ -- ^ The types from the data type/data family instance declaration
786+ -> [ConstructorInfo]
779787 -- ^ Constructors for which to generate JSON parsing code.
780788 -> Q Exp
781789
782−consFromJSON _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
783− ++ "Not a single constructor given!"
790+consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "
791+ ++ "Not a single constructor given!"
784792
785−consFromJSON jc tName opts cons = do
793+consFromJSON jc tName opts vars cons = do
786794 value <- newName "value"
787795 pjs <- newNameList "_pj" $ arityInt jc
788796 pjls <- newNameList "_pjl" $ arityInt jc
789797 let zippedPJs = zip pjs pjls
790798 interleavedPJs = interleave pjs pjls
791− lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value zippedPJs
799+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars
800+ tvMap = M.fromList $ zip lastTyVars zippedPJs
801+ lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap
792802
793803 where
794− lamExpr value pjs = case cons of
804+ checkExi tvMap con = checkExistentialContext jc tvMap
805+ (constructorContext con)
806+ (constructorName con)
807+
808+ lamExpr value tvMap = case cons of
795809 [con]
796810 | not (tagSingleConstructors opts)
797− -> parseArgs jc pjs tName opts con (Right value)
811+ -> checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right value)
798812 _ | sumEncoding opts == UntaggedValue
799− -> parseUntaggedValue pjs cons value
813+ -> parseUntaggedValue tvMap cons value
800814 | otherwise
801815 -> caseE (varE value) $
802816 if allNullaryToStringTag opts && all isNullary cons
803817 then allNullaryMatches
804− else mixedMatches pjs
818+ else mixedMatches tvMap
805819
806820 allNullaryMatches =
807821 [ do txt <- newName "txt"
@@ -815,7 +829,7 @@ consFromJSON jc tName opts cons = do
815829 )
816830 ([|pure|] `appE` conE conName)
817831 | con <- cons
818− , let conName = getConName con
832+ , let conName = constructorName con
819833 ]
820834 ++
821835 [ liftM2 (,)
@@ -836,13 +850,13 @@ consFromJSON jc tName opts cons = do
836850 []
837851 ]
838852
839− mixedMatches pjs =
853+ mixedMatches tvMap =
840854 case sumEncoding opts of
841855 TaggedObject {tagFieldName, contentsFieldName} ->
842− parseObject $ parseTaggedObject pjs tagFieldName contentsFieldName
856+ parseObject $ parseTaggedObject tvMap tagFieldName contentsFieldName
843857 UntaggedValue -> error "UntaggedValue: Should be handled already"
844858 ObjectWithSingleField ->
845− parseObject $ parseObjectWithSingleField pjs
859+ parseObject $ parseObjectWithSingleField tvMap
846860 TwoElemArray ->
847861 [ do arr <- newName "array"
848862 match (conP 'Array [varP arr])
@@ -850,7 +864,7 @@ consFromJSON jc tName opts cons = do
850864 [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr)
851865 [|(==)|]
852866 (litE $ integerL 2))
853− (parse2ElemArray pjs arr)
867+ (parse2ElemArray tvMap arr)
854868 , liftM2 (,) (normalG [|otherwise|])
855869 ([|not2ElemArray|]
856870 `appE` litE (stringL $ show tName)
@@ -881,20 +895,24 @@ consFromJSON jc tName opts cons = do
881895 []
882896 ]
883897
884− parseTaggedObject pjs typFieldName valFieldName obj = do
898+ parseTaggedObject tvMap typFieldName valFieldName obj = do
885899 conKey <- newName "conKey"
886900 doE [ bindS (varP conKey)
887901 (infixApp (varE obj)
888902 [|(.:)|]
889903 ([|T.pack|] `appE` stringE typFieldName))
890− , noBindS $ parseContents pjs conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
904+ , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject
891905 ]
892906
893− parseUntaggedValue pjs cons' conVal =
907+ parseUntaggedValue tvMap cons' conVal =
894908 foldr1 (\e e' -> infixApp e [|(<|>)|] e')
895− (map (\x -> parseValue pjs x conVal) cons')
909+ (map (\x -> parseValue tvMap x conVal) cons')
896910
897− parseValue _pjs (NormalC conName []) conVal = do
911+ parseValue _tvMap
912+ ConstructorInfo { constructorName = conName
913+ , constructorVariant = NormalConstructor
914+ , constructorFields = [] }
915+ conVal = do
898916 str <- newName "str"
899917 caseE (varE conVal)
900918 [ match (conP 'String [varP str])
@@ -907,11 +925,11 @@ consFromJSON jc tName opts cons = do
907925 []
908926 , matchFailed tName conName "String"
909927 ]
910− parseValue pjs con conVal =
911− parseArgs jc pjs tName opts con (Right conVal)
928+ parseValue tvMap con conVal =
929+ checkExi tvMap con $ parseArgs jc tvMap tName opts con (Right conVal)
912930
913931
914− parse2ElemArray pjs arr = do
932+ parse2ElemArray tvMap arr = do
915933 conKey <- newName "conKey"
916934 conVal <- newName "conVal"
917935 let letIx n ix =
@@ -926,7 +944,7 @@ consFromJSON jc tName opts cons = do
926944 (caseE (varE conKey)
927945 [ do txt <- newName "txt"
928946 match (conP 'String [varP txt])
929− (normalB $ parseContents pjs
947+ (normalB $ parseContents tvMap
930948 txt
931949 (Right conVal)
932950 'conNotFoundFail2ElemArray
@@ -943,12 +961,12 @@ consFromJSON jc tName opts cons = do
943961 ]
944962 )
945963
946− parseObjectWithSingleField pjs obj = do
964+ parseObjectWithSingleField tvMap obj = do
947965 conKey <- newName "conKey"
948966 conVal <- newName "conVal"
949967 caseE ([e|H.toList|] `appE` varE obj)
950968 [ match (listP [tupP [varP conKey, varP conVal]])
951− (normalB $ parseContents pjs conKey (Right conVal) 'conNotFoundFailObjectSingleField)
969+ (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField)
952970 []
953971 , do other <- newName "other"
954972 match (varP other)
@@ -959,7 +977,7 @@ consFromJSON jc tName opts cons = do
959977 []
960978 ]
961979
962− parseContents pjs conKey contents errorFun =
980+ parseContents tvMap conKey contents errorFun =
963981 caseE (varE conKey)
964982 [ match wildP
965983 ( guardedB $
@@ -967,7 +985,8 @@ consFromJSON jc tName opts cons = do
967985 [|(==)|]
968986 ([|T.pack|] `appE`
969987 conNameExp opts con)
970− e <- parseArgs jc pjs tName opts con contents
988+ e <- checkExi tvMap con $
989+ parseArgs jc tvMap tName opts con contents
971990 return (g, e)
972991 | con <- cons
973992 ]
@@ -980,7 +999,7 @@ consFromJSON jc tName opts cons = do
980999 . stringL
9811000 . constructorTagModifier opts
9821001 . nameBase
983− . getConName
1002+ . constructorName
9841003 ) cons
9851004 )
9861005 `appE` ([|T.unpack|] `appE` varE conKey)
@@ -1029,10 +1048,10 @@ parseRecord :: JSONClass
10291048 -> Options
10301049 -> Name
10311050 -> Name
1032− -> [VarStrictType]
1051+ -> [Name]
10331052 -> Name
10341053 -> ExpQ
1035−parseRecord jc tvMap argTys opts tName conName ts obj =
1054+parseRecord jc tvMap argTys opts tName conName fields obj =
10361055 foldl' (\a b -> infixApp a [|(<*>)|] b)
10371056 (infixApp (conE conName) [|(<$>)|] x)
10381057 xs
@@ -1044,7 +1063,7 @@ parseRecord jc tvMap argTys opts tName conName ts obj =
10441063 `appE` varE obj
10451064 `appE` ( [|T.pack|] `appE` fieldLabelExp opts field
10461065 )
1047− | ((field, _, _), argTy) <- zip ts argTys
1066+ | (field, argTy) <- zip fields argTys
10481067 ]
10491068
10501069getValField :: Name -> String -> [MatchQ] -> Q Exp
@@ -1063,67 +1082,82 @@ matchCases (Right valName) = caseE (varE valName)
10631082
10641083-- | Generates code to parse the JSON encoding of a single constructor.
10651084parseArgs :: JSONClass -- ^ The FromJSON variant being derived.
1066− -> [(Name, Name)] -- ^ The names of the encoding/decoding function arguments.
1085+ -> TyVarMap -- ^ Maps the last type variables to their decoding
1086+ -- function arguments.
10671087 -> Name -- ^ Name of the type to which the constructor belongs.
10681088 -> Options -- ^ Encoding options.
1069− -> Con -- ^ Constructor for which to generate JSON parsing code.
1089+ -> ConstructorInfo -- ^ Constructor for which to generate JSON parsing code.
10701090 -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or
10711091 -- Right valName
10721092 -> Q Exp
10731093-- 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
1094+parseArgs _ _ _ _
1095+ ConstructorInfo { constructorName = conName
1096+ , constructorVariant = NormalConstructor
1097+ , constructorFields = [] }
1098+ (Left _) =
1099+ [|pure|] `appE` conE conName
1100+parseArgs _ _ tName _
1101+ ConstructorInfo { constructorName = conName
1102+ , constructorVariant = NormalConstructor
1103+ , constructorFields = [] }
1104+ (Right valName) =
1105+ caseE (varE valName) $ parseNullaryMatches tName conName
10801106
10811107-- 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
1108+parseArgs jc tvMap _ _
1109+ ConstructorInfo { constructorName = conName
1110+ , constructorVariant = NormalConstructor
1111+ , constructorFields = [argTy] }
1112+ contents = do
1113+ argTy' <- resolveTypeSynonyms argTy
1114+ matchCases contents $ parseUnaryMatches jc tvMap argTy' conName
10851115
10861116-- 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
1117+parseArgs jc tvMap tName _
1118+ ConstructorInfo { constructorName = conName
1119+ , constructorVariant = NormalConstructor
1120+ , constructorFields = argTys }
1121+ contents = do
1122+ argTys' <- mapM resolveTypeSynonyms argTys
1123+ let len = genericLength argTys'
1124+ matchCases contents $ parseProduct jc tvMap argTys' tName conName len
10911125
10921126-- 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− ]
1127+parseArgs jc tvMap tName opts
1128+ ConstructorInfo { constructorName = conName
1129+ , constructorVariant = RecordConstructor fields
1130+ , constructorFields = argTys }
1131+ (Left (_, obj)) = do
1132+ argTys' <- mapM resolveTypeSynonyms argTys
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 }
1138+ (Right valName) =
1139+ case (unwrapUnaryRecords opts,argTys) of
1140+ (True,[_])-> parseArgs jc tvMap tName opts
1141+ (info{constructorVariant = NormalConstructor})
1142+ (Right valName)
1143+ _ -> do
1144+ obj <- newName "recObj"
1145+ argTys' <- mapM resolveTypeSynonyms argTys
1146+ caseE (varE valName)
1147+ [ match (conP 'Object [varP obj]) (normalB $
1148+ parseRecord jc tvMap argTys' opts tName conName fields obj) []
1149+ , matchFailed tName conName "Object"
1150+ ]
11061151
11071152-- Infix constructors. Apart from syntax these are the same as
11081153-- 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
1154+parseArgs jc tvMap tName _
1155+ ConstructorInfo { constructorName = conName
1156+ , constructorVariant = InfixConstructor
1157+ , constructorFields = argTys }
1158+ contents = do
1159+ argTys' <- mapM resolveTypeSynonyms argTys
1160+ matchCases contents $ parseProduct jc tvMap argTys' tName conName 2
11271161
11281162-- | Generates code to parse the JSON encoding of an n-ary
11291163-- constructor.
@@ -1278,7 +1312,8 @@ deriveJSONBoth dtj dfj opts name =
12781312 liftM2 (++) (dtj opts name) (dfj opts name)
12791313
12801314-- | 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)]
12821317 -- ^ The class methods and the functions which derive them.
12831318 -> JSONClass
12841319 -- ^ The class for which to generate an instance.
@@ -1288,27 +1323,30 @@ deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Con] -> Q Exp)]
12881323 -- ^ Name of the type for which to generate a class instance
12891324 -- declaration.
12901325 -> 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
1326+deriveJSONClass consFuns jc opts name = do
1327+ info <- reifyDatatype name
1328+ case info of
1329+ DatatypeInfo { datatypeContext = ctxt
1330+ , datatypeName = parentName
1331+ , datatypeVars = vars
1332+ , datatypeVariant = variant
1333+ , datatypeCons = cons
1334+ } -> do
12971335 (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) ->
1336+ <- buildTypeInstance parentName jc ctxt vars variant
1337+ (:[]) <$> instanceD (return instanceCxt)
1338+ (return instanceType)
1339+ (methodDecs parentName vars cons)
1340+ where
1341+ methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]
1342+ methodDecs parentName vars cons = flip map consFuns $ \(jf, jfMaker) ->
13051343 funD (jsonFunValName jf (arity jc))
13061344 [ clause []
1307− (normalB $ jfMaker jc name' opts cons)
1345+ (normalB $ jfMaker jc parentName opts vars cons)
13081346 []
13091347 ]
13101348
1311−mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)
1349+mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q Exp)
13121350 -- ^ The function which derives the expression.
13131351 -> JSONClass
13141352 -- ^ Which class's method is being derived.
@@ -1317,15 +1355,20 @@ mkFunCommon :: (JSONClass -> Name -> Options -> [Con] -> Q Exp)
13171355 -> Name
13181356 -- ^ Name of the encoded type.
13191357 -> 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
1358+mkFunCommon consFun jc opts name = do
1359+ info <- reifyDatatype name
1360+ case info of
1361+ DatatypeInfo { datatypeContext = ctxt
1362+ , datatypeName = parentName
1363+ , datatypeVars = vars
1364+ , datatypeVariant = variant
1365+ , datatypeCons = cons
1366+ } -> do
1367+ -- We force buildTypeInstance here since it performs some checks for whether
1368+ -- or not the provided datatype's kind matches the derived method's
1369+ -- typeclass, and produces errors if it can't.
1370+ !_ <- buildTypeInstance parentName jc ctxt vars variant
1371+ consFun jc parentName opts vars cons
13291372
13301373dispatchFunByType :: JSONClass
13311374 -> JSONFun
@@ -1380,190 +1423,24 @@ dispatchParseJSON jc n tvMap = dispatchFunByType jc ParseJSON n tvMap False
13801423-- Utility functions
13811424--------------------------------------------------------------------------------
13821425
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.
1426+-- For the given Types, generate an instance context and head.
14611427buildTypeInstance :: Name
14621428 -- ^ The type constructor or data family name
14631429 -> JSONClass
14641430 -- ^ The typeclass to derive
14651431 -> Cxt
14661432 -- ^ 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
1433+ -> [Type]
1434+ -- ^ The types to instantiate the instance with
1435+ -> DatatypeVariant
1436+ -- ^ Are we dealing with a data family instance or not
14721437 -> 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
1438+buildTypeInstance tyConName jc dataCxt varTysOrig variant = do
15621439 -- Make sure to expand through type/kind synonyms! Otherwise, the
15631440 -- eta-reduction check might get tripped up over type variables in a
15641441 -- synonym that are actually dropped.
15651442 -- (See GHC Trac #11416 for a scenario where this actually happened.)
1566− varTysExp <- mapM expandSyn varTysOrig
1443+ varTysExp <- mapM resolveTypeSynonyms varTysOrig
15671444
15681445 let remainingLength :: Int
15691446 remainingLength = length varTysOrig - arityInt jc
@@ -1593,7 +1470,7 @@ buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
15931470 -- All of the type variables mentioned in the dropped types
15941471 -- (post-synonym expansion)
15951472 droppedTyVarNames :: [Name]
1596− droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst
1473+ droppedTyVarNames = freeVariables droppedTysExpSubst
15971474
15981475 -- If any of the dropped types were polykinded, ensure that they are of kind *
15991476 -- after substituting * for the dropped kind variables. If not, throw an error.
@@ -1634,6 +1511,13 @@ buildTypeInstanceFromTys tyConName jc dataCxt varTysOrig isDataFamily = do
16341511 map (substNamesWithKindStar (droppedKindVarNames `union` kvNames'))
16351512 $ take remainingLength varTysOrig
16361513
1514+ isDataFamily :: Bool
1515+ isDataFamily = case variant of
1516+ Datatype -> False
1517+ Newtype -> False
1518+ DataInstance -> True
1519+ NewtypeInstance -> True
1520+
16371521 remainingTysOrigSubst' :: [Type]
16381522 -- See Note [Kind signatures in derived instances] for an explanation
16391523 -- of the isDataFamily check.
@@ -1687,55 +1571,6 @@ deriveConstraint jc t
16871571 jcConstraint = jsonClassName . JSONClass (direction jc)
16881572
16891573{-
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−
17391574Note [Kind signatures in derived instances]
17401575~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
17411576
@@ -1813,50 +1648,14 @@ things we can do to make instance contexts that work for 80% of use cases:
18131648 and perform kind substitution as in the other cases.
18141649-}
18151650
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)
1651+checkExistentialContext :: JSONClass -> TyVarMap -> Cxt -> Name
1652+ -> Q a -> Q a
1653+checkExistentialContext jc tvMap ctxt conName q =
1654+ if (any (`predMentionsName` M.keys tvMap) ctxt
1655+ || M.size tvMap < arityInt jc)
1656+ && not (allowExQuant jc)
1657+ then existentialContextError conName
1658+ else q
18601659
18611660{-
18621661Note [Matching functions with GADT type variables]
@@ -1896,24 +1695,6 @@ Both.
18961695-- are the function arguments of types (b -> Value) and ([b] -> Value).
18971696type TyVarMap = Map Name (Name, Name)
18981697
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−
19171698-- | Returns True if a Type has kind *.
19181699hasKindStar :: Type -> Bool
19191700hasKindStar VarT{} = True
@@ -1938,27 +1719,6 @@ isStarOrVar _ = False
19381719newNameList :: String -> Int -> Q [Name]
19391720newNameList prefix len = mapM newName [prefix ++ show n | n <- [1..len]]
19401721
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−
19621722-- | @hasKindVarChain n kind@ Checks if @kind@ is of the form
19631723-- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or
19641724-- kind variables.
@@ -1966,7 +1726,7 @@ hasKindVarChain :: Int -> Type -> Maybe [Name]
19661726hasKindVarChain kindArrows t =
19671727 let uk = uncurryKind (tyKind t)
19681728 in if (NE.length uk - 1 == kindArrows) && F.all isStarOrVar uk
1969− then Just (concatMap tyVarNamesOfKind uk)
1729+ then Just (concatMap freeVariables uk)
19701730 else Nothing
19711731
19721732-- | If a Type is a SigT, returns its kind signature. Otherwise, return *.
@@ -1986,17 +1746,6 @@ varTToNameMaybe _ = Nothing
19861746varTToName :: Type -> Name
19871747varTToName = fromMaybe (error "Not a type variable!") . varTToNameMaybe
19881748
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−
20001749interleave :: [a] -> [a] -> [a]
20011750interleave (a1:a1s) (a2:a2s) = a1:a2:interleave a1s a2s
20021751interleave _ _ = []
@@ -2128,12 +1877,12 @@ createKindChain = go starK
21281877#endif
21291878
21301879-- | Makes a string literal expression from a constructor's name.
2131−conNameExp :: Options -> Con -> Q Exp
1880+conNameExp :: Options -> ConstructorInfo -> Q Exp
21321881conNameExp opts = litE
21331882 . stringL
21341883 . constructorTagModifier opts
21351884 . nameBase
2136− . getConName
1885+ . constructorName
21371886
21381887-- | Creates a string literal expression from a record field label.
21391888fieldLabelExp :: Options -- ^ Encoding options
@@ -2178,73 +1927,15 @@ canEtaReduce remaining dropped =
21781927-- Expanding type synonyms
21791928-------------------------------------------------------------------------------
21801929
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
1930+applySubstitutionKind :: Map Name Kind -> Type -> Type
22401931#if MIN_VERSION_template_haskell(2,8,0)
2241−substKind = substType
1932+applySubstitutionKind = applySubstitution
22421933#else
2243−substKind _ t = t -- There are no kind variables!
1934+applySubstitutionKind _ t = t
22441935#endif
22451936
22461937substNameWithKind :: Name -> Kind -> Type -> Type
2247−substNameWithKind n k = substKind (M.singleton n k)
1938+substNameWithKind n k = applySubstitutionKind (M.singleton n k)
22481939
22491940substNamesWithKindStar :: [Name] -> Type -> Type
22501941substNamesWithKindStar ns t = foldr' (`substNameWithKind` starK) t ns