@@ -89,23 +89,32 @@ import Data.Aeson.Types.Internal (Encoding(..))
8989import Data.Bool ( Bool(False, True), otherwise, (&&) , not)
9090import Data.Either ( Either(Left, Right) )
9191import Data.Eq ( (==) )
92−import Data.Function ( ($), (.) )
92+import Data.Function ( ($), (.), flip )
9393import Data.Functor ( fmap )
9494import Data.Int ( Int )
95−import Data.List ( (++), foldl, foldl', intercalate, intersperse
96− , length, map, zip, genericLength, all, partition
95+import Data.List ( (++), all, any, filter, find, foldl, foldl'
96+ , genericLength , intercalate , intersperse, length, map
97+ , partition, zip
9798 )
9899import Data.Maybe ( Maybe(Nothing, Just), catMaybes )
99100import Data.Monoid ( (<>), mconcat )
100101import Language.Haskell.TH
101102import Language.Haskell.TH.Syntax ( VarStrictType )
102−import Prelude ( String, (-), Integer, error, foldr1, fromIntegral )
103+import Prelude ( String, (-), Integer, error, foldr1, fromIntegral
104+ , snd, uncurry
105+ )
106+#if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710
107+import Prelude ( drop )
108+#endif
103109import Text.Printf ( printf )
104110import Text.Show ( show )
105111import qualified Data.Aeson as A
106112import qualified Data.Aeson.Encode.Builder as E
107113import qualified Data.Aeson.Encode.Functions as E
108114import qualified Data.HashMap.Strict as H ( lookup, toList )
115+#if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710
116+import qualified Data.Set as Set ( Set, empty, singleton, size, union, unions )
117+#endif
109118import qualified Data.Text as T ( Text, pack, unpack )
110119import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList )
111120import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
@@ -153,12 +162,12 @@ deriveToJSON :: Options
153162 -- declaration.
154163 -> Q [Dec]
155164deriveToJSON opts name =
156− withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
165+ withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys
157166 where
158− fromCons :: [TyVarBndr] -> [Con] -> Q Dec
159− fromCons tvbs cons =
160− instanceD (applyCon ''ToJSON typeNames)
161− (classType `appT` instanceType)
167+ fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
168+ fromCons name' tvbs cons mbTys =
169+ instanceD instanceCxt
170+ instanceType
162171 [ funD 'toJSON
163172 [ clause []
164173 (normalB $ consToValue opts cons)
@@ -171,23 +180,22 @@ deriveToJSON opts name =
171180 ]
172181 ]
173182 where
174− classType = conT ''ToJSON
175− typeNames = map tvbName tvbs
176− instanceType = foldl' appT (conT name) $ map varT typeNames
183+ (instanceCxt, instanceType) =
184+ buildTypeInstance name' ''ToJSON tvbs mbTys
177185
178186-- | Generates a lambda expression which encodes the given data type as a
179187-- 'Value'.
180188mkToJSON :: Options -- ^ Encoding options.
181189 -> Name -- ^ Name of the type to encode.
182190 -> Q Exp
183−mkToJSON opts name = withType name (\_ cons -> consToValue opts cons)
191+mkToJSON opts name = withType name (\_ _ cons _ -> consToValue opts cons)
184192
185193-- | Generates a lambda expression which encodes the given data type
186194-- as a JSON string.
187195mkToEncoding :: Options -- ^ Encoding options.
188196 -> Name -- ^ Name of the type to encode.
189197 -> Q Exp
190−mkToEncoding opts name = withType name (\_ cons -> consToEncoding opts cons)
198+mkToEncoding opts name = withType name (\_ _ cons _ -> consToEncoding opts cons)
191199
192200-- | Helper function used by both 'deriveToJSON' and 'mkToJSON'. Generates
193201-- code to generate a 'Value' of a number of constructors. All constructors
@@ -537,22 +545,21 @@ deriveFromJSON :: Options
537545 -- declaration.
538546 -> Q [Dec]
539547deriveFromJSON opts name =
540− withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons
548+ withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys
541549 where
542− fromCons :: [TyVarBndr] -> [Con] -> Q Dec
543− fromCons tvbs cons =
544− instanceD (applyCon ''FromJSON typeNames)
545− (classType `appT` instanceType)
550+ fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
551+ fromCons name' tvbs cons mbTys =
552+ instanceD instanceCxt
553+ instanceType
546554 [ funD 'parseJSON
547555 [ clause []
548− (normalB $ consFromJSON name opts cons)
556+ (normalB $ consFromJSON name' opts cons)
549557 []
550558 ]
551559 ]
552560 where
553− classType = conT ''FromJSON
554− typeNames = map tvbName tvbs
555− instanceType = foldl' appT (conT name) $ map varT typeNames
561+ (instanceCxt, instanceType) =
562+ buildTypeInstance name' ''FromJSON tvbs mbTys
556563
557564-- | Generates a lambda expression which parses the JSON encoding of the given
558565-- data type.
@@ -560,7 +567,7 @@ mkParseJSON :: Options -- ^ Encoding options.
560567 -> Name -- ^ Name of the encoded type.
561568 -> Q Exp
562569mkParseJSON opts name =
563− withType name (\_ cons -> consFromJSON name opts cons)
570+ withType name (\name' _ cons _ -> consFromJSON name' opts cons)
564571
565572-- | Helper function used by both 'deriveFromJSON' and 'mkParseJSON'. Generates
566573-- code to parse the JSON encoding of a number of constructors. All constructors
@@ -988,14 +995,19 @@ parseTypeMismatch' conName tName expected actual =
988995
989996-- | Boilerplate for top level splices.
990997--
991−-- The given 'Name' must be from a type constructor. Furthermore, the
992−-- type constructor must be either a data type or a newtype. Any other
993−-- value will result in an exception.
998+-- The given 'Name' must meet one of two criteria:
999+--
1000+-- 1. It must be the name of a type constructor of a plain data type or newtype.
1001+-- 2. It must be the name of a data family instance or newtype instance constructor.
1002+
1003+-- Any other value will result in an exception.
9941004withType :: Name
995− -> ([TyVarBndr] -> [Con] -> Q a)
1005+ -> (Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a)
9961006 -- ^ Function that generates the actual code. Will be applied
997− -- to the type variable binders and constructors extracted
998− -- from the given 'Name'.
1007+ -- to the datatype/data family 'Name', type variable binders and
1008+ -- constructors extracted from the given 'Name'. If the 'Name' is
1009+ -- from a data family instance constructor, it will also have its
1010+ -- instantiated types; otherwise, it will be 'Nothing'.
9991011 -> Q a
10001012 -- ^ Resulting value in the 'Q'uasi monad.
10011013withType name f = do
@@ -1003,11 +1015,125 @@ withType name f = do
10031015 case info of
10041016 TyConI dec ->
10051017 case dec of
1006− DataD _ _ tvbs cons _ -> f tvbs cons
1007− NewtypeD _ _ tvbs con _ -> f tvbs [con]
1008− other -> error $ "Data.Aeson.TH.withType: Unsupported type: "
1009− ++ show other
1010− _ -> error "Data.Aeson.TH.withType: I need the name of a type."
1018+ DataD _ _ tvbs cons _ -> f name tvbs cons Nothing
1019+ NewtypeD _ _ tvbs con _ -> f name tvbs [con] Nothing
1020+ other -> error $ ns ++ "Unsupported type: " ++ show other
1021+ DataConI _ _ parentName _ -> do
1022+ parentInfo <- reify parentName
1023+ case parentInfo of
1024+ FamilyI (FamilyD DataFam _ tvbs _) decs ->
1025+ let instDec = flip find decs $ \dec -> case dec of
1026+ DataInstD _ _ _ cons _ -> any ((name ==) . getConName) cons
1027+ NewtypeInstD _ _ _ con _ -> name == getConName con
1028+ _ -> error $ ns ++ "Must be a data or newtype instance."
1029+ in case instDec of
1030+ Just (DataInstD _ _ instTys cons _)
1031+ -> f parentName tvbs cons $ Just instTys
1032+ Just (NewtypeInstD _ _ instTys con _)
1033+ -> f parentName tvbs [con] $ Just instTys
1034+ _ -> error $ ns ++
1035+ "Could not find data or newtype instance constructor."
1036+ _ -> error $ ns ++ "Data constructor " ++ show name ++
1037+ " is not from a data family instance constructor."
1038+ FamilyI (FamilyD DataFam _ _ _) _ -> error $ ns ++
1039+ "Cannot use a data family name. Use a data family instance constructor instead."
1040+ _ -> error $ ns ++ "I need the name of a plain data type constructor, "
1041+ ++ "or a data family instance constructor."
1042+ where
1043+ ns :: String
1044+ ns = "Data.Aeson.TH.withType: "
1045+
1046+-- | Infer the context and instance head needed for a FromJSON or ToJSON instance.
1047+buildTypeInstance :: Name
1048+ -- ^ The type constructor or data family name
1049+ -> Name
1050+ -- ^ The typeclass name ('ToJSON' or 'FromJSON')
1051+ -> [TyVarBndr]
1052+ -- ^ The type variables from the data type/data family declaration
1053+ -> Maybe [Type]
1054+ -- ^ 'Just' the types used to instantiate a data family instance,
1055+ -- or 'Nothing' if it's a plain data type
1056+ -> (Q Cxt, Q Type)
1057+ -- ^ The resulting 'Cxt' and 'Type' to use in a class instance
1058+-- Plain data type/newtype case
1059+buildTypeInstance tyConName constraint tvbs Nothing =
1060+ (applyCon constraint typeNames, conT constraint `appT` instanceType)
1061+ where
1062+ typeNames :: [Name]
1063+ typeNames = map tvbName tvbs
1064+
1065+ instanceType :: Q Type
1066+ instanceType = applyTyCon tyConName $ map varT typeNames
1067+-- Data family instance case
1068+buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) =
1069+ (applyCon constraint lhsTvbNames, conT constraint `appT` instanceType)
1070+ where
1071+ -- We need to make sure that type variables in the instance head which have
1072+ -- constraints aren't poly-kinded, e.g.,
1073+ --
1074+ -- @
1075+ -- instance ToJSON a => ToJSON (Foo (a :: k)) where
1076+ -- @
1077+ --
1078+ -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').
1079+ instanceType :: Q Type
1080+ instanceType = applyTyCon dataFamName $ map (return . unSigT) rhsTypes
1081+
1082+ -- We need to mindful of an old GHC bug which causes kind variables appear in
1083+ -- @instTysAndKinds@ (as the name suggests) if (1) @PolyKinds@ is enabled, and
1084+ -- (2) either GHC 7.6 or 7.8 is being used (for more info, see
1085+ -- https://ghc.haskell.org/trac/ghc/ticket/9692).
1086+ --
1087+ -- Since Template Haskell doesn't seem to have a mechanism for detecting which
1088+ -- language extensions are enabled, we do the next-best thing by counting
1089+ -- the number of distinct kind variables in the data family declaration, and
1090+ -- then dropping that number of entries from @instTysAndKinds@
1091+ instTypes :: [Type]
1092+ instTypes =
1093+#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))
1094+ instTysAndKinds
1095+#else
1096+ drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) tvbs)
1097+ instTysAndKinds
1098+#endif
1099+
1100+ lhsTvbNames :: [Name]
1101+ lhsTvbNames = map (tvbName . uncurry replaceTyVarName)
1102+ . filter (isTyVar . snd)
1103+ $ zip tvbs rhsTypes
1104+
1105+ -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable
1106+ -- in @instTypes@ are provided (as a result of this bug:
1107+ -- https://ghc.haskell.org/trac/ghc/ticket/9692). To work around this, we borrow
1108+ -- some type variables from the data family instance declaration.
1109+ rhsTypes :: [Type]
1110+ rhsTypes =
1111+#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
1112+ instTypes ++ map tvbToType
1113+ (drop (length instTypes)
1114+ tvbs)
1115+#else
1116+ instTypes
1117+#endif
1118+
1119+#if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710
1120+distinctKindVars :: Kind -> Set.Set Name
1121+distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2
1122+distinctKindVars (SigT k _) = distinctKindVars k
1123+distinctKindVars (VarT k) = Set.singleton k
1124+distinctKindVars _ = Set.empty
1125+
1126+-- | Extracts the kind from a type variable binder.
1127+tvbKind :: TyVarBndr -> Kind
1128+tvbKind (PlainTV _ ) = starK
1129+tvbKind (KindedTV _ k) = k
1130+#endif
1131+
1132+#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
1133+tvbToType :: TyVarBndr -> Type
1134+tvbToType (PlainTV n) = VarT n
1135+tvbToType (KindedTV n k) = SigT (VarT n) k
1136+#endif
10111137
10121138-- | Extracts the name from a constructor.
10131139getConName :: Con -> Name
@@ -1021,6 +1147,28 @@ tvbName :: TyVarBndr -> Name
10211147tvbName (PlainTV name ) = name
10221148tvbName (KindedTV name _) = name
10231149
1150+-- | Replace the Name of a TyVarBndr with one from a Type (if the Type has a Name).
1151+replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr
1152+replaceTyVarName tvb (SigT t _) = replaceTyVarName tvb t
1153+replaceTyVarName (PlainTV _) (VarT n) = PlainTV n
1154+replaceTyVarName (KindedTV _ k) (VarT n) = KindedTV n k
1155+replaceTyVarName tvb _ = tvb
1156+
1157+-- | Fully applies a type constructor to its type variables.
1158+applyTyCon :: Name -> [Q Type] -> Q Type
1159+applyTyCon = foldl' appT . conT
1160+
1161+-- | Is the given type a variable?
1162+isTyVar :: Type -> Bool
1163+isTyVar (VarT _) = True
1164+isTyVar (SigT t _) = isTyVar t
1165+isTyVar _ = False
1166+
1167+-- | Peel off a kind signature from a Type (if it has one).
1168+unSigT :: Type -> Type
1169+unSigT (SigT t _) = t
1170+unSigT t = t
1171+
10241172-- | Makes a string literal expression from a constructor's name.
10251173conNameExp :: Options -> Con -> Q Exp
10261174conNameExp opts = litE