@@ -108,19 +108,27 @@ import Data.Eq ( (==) )
108108import Data.Function ( ($), (.), flip )
109109import Data.Functor ( fmap )
110110import Data.Int ( Int )
111−import Data.List ( (++), all, any, filter, find, foldl, foldl'
111+import Data.List ( (++), all, any, find, foldl, foldl'
112112 , genericLength , intercalate , intersperse, length, map
113113 , partition, zip
114114 )
115+import Data.Map ( Map )
115116import Data.Maybe ( Maybe(Nothing, Just), catMaybes )
116117import Data.Monoid ( (<>), mconcat )
117118import Language.Haskell.TH
118119import Language.Haskell.TH.Syntax ( VarStrictType )
119120import Prelude ( String, (-), Integer, error, foldr1, fromIntegral
120− , snd, uncurry
121+ , splitAt, zipWith
121122 )
122−#if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710
123−import Prelude ( drop )
123+#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))
124+import Data.Foldable ( foldr' )
125+import qualified Data.Map as M ( singleton )
126+import Data.List ( nub )
127+import Language.Haskell.TH.Syntax ( mkNameG_tc )
128+import Prelude ( concatMap, uncurry )
129+#endif
130+#if MIN_VERSION_template_haskell(2,11,0)
131+import Prelude ( head )
124132#endif
125133import Text.Printf ( printf )
126134import Text.Show ( show )
@@ -128,9 +136,7 @@ import qualified Data.Aeson as A
128136import qualified Data.Aeson.Encode.Builder as E
129137import qualified Data.Aeson.Encode.Functions as E
130138import qualified Data.HashMap.Strict as H ( lookup, toList )
131−#if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710
132−import qualified Data.Set as Set ( Set, empty, singleton, size, union, unions )
133−#endif
139+import qualified Data.Map as M ( fromList, findWithDefault )
134140import qualified Data.Text as T ( Text, pack, unpack )
135141import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList )
136142import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
@@ -182,9 +188,10 @@ deriveToJSON opts name =
182188 withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys
183189 where
184190 fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
185− fromCons name' tvbs cons mbTys =
186− instanceD instanceCxt
187− instanceType
191+ fromCons name' tvbs cons mbTys = do
192+ (instanceCxt, instanceType) <- buildTypeInstance name' ''ToJSON tvbs mbTys
193+ instanceD (return instanceCxt)
194+ (return instanceType)
188195 [ funD 'toJSON
189196 [ clause []
190197 (normalB $ consToValue opts cons)
@@ -196,9 +203,6 @@ deriveToJSON opts name =
196203 []
197204 ]
198205 ]
199− where
200− (instanceCxt, instanceType) =
201− buildTypeInstance name' ''ToJSON tvbs mbTys
202206
203207-- | Generates a lambda expression which encodes the given data type or
204208-- data family instance constructor as a 'Value'.
@@ -420,6 +424,15 @@ argsToValue opts multiCons (InfixC _ conName _) = do
420424argsToValue opts multiCons (ForallC _ _ con) =
421425 argsToValue opts multiCons con
422426
427+#if MIN_VERSION_template_haskell(2,11,0)
428+-- GADTs.
429+argsToValue opts multiCons (GadtC conNames ts _) =
430+ argsToValue opts multiCons $ NormalC (head conNames) ts
431+
432+argsToValue opts multiCons (RecGadtC conNames ts _) =
433+ argsToValue opts multiCons $ RecC (head conNames) ts
434+#endif
435+
423436isMaybe :: (a, (b, c, Type)) -> Bool
424437isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe
425438isMaybe _ = False
@@ -554,6 +567,14 @@ argsToEncoding opts multiCons (InfixC _ conName _) = do
554567argsToEncoding opts multiCons (ForallC _ _ con) =
555568 argsToEncoding opts multiCons con
556569
570+#if MIN_VERSION_template_haskell(2,11,0)
571+-- GADTs.
572+argsToEncoding opts multiCons (GadtC conNames ts _) =
573+ argsToEncoding opts multiCons $ NormalC (head conNames) ts
574+
575+argsToEncoding opts multiCons (RecGadtC conNames ts _) =
576+ argsToEncoding opts multiCons $ RecC (head conNames) ts
577+#endif
557578
558579--------------------------------------------------------------------------------
559580-- FromJSON
@@ -571,18 +592,16 @@ deriveFromJSON opts name =
571592 withType name $ \name' tvbs cons mbTys -> fmap (:[]) $ fromCons name' tvbs cons mbTys
572593 where
573594 fromCons :: Name -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Dec
574− fromCons name' tvbs cons mbTys =
575− instanceD instanceCxt
576− instanceType
595+ fromCons name' tvbs cons mbTys = do
596+ (instanceCxt, instanceType) <- buildTypeInstance name' ''FromJSON tvbs mbTys
597+ instanceD (return instanceCxt)
598+ (return instanceType)
577599 [ funD 'parseJSON
578600 [ clause []
579601 (normalB $ consFromJSON name' opts cons)
580602 []
581603 ]
582604 ]
583− where
584− (instanceCxt, instanceType) =
585− buildTypeInstance name' ''FromJSON tvbs mbTys
586605
587606-- | Generates a lambda expression which parses the JSON encoding of the given
588607-- data type or data family instance constructor.
@@ -888,6 +907,16 @@ parseArgs tName _ (InfixC _ conName _) (Right valName) =
888907parseArgs tName opts (ForallC _ _ con) contents =
889908 parseArgs tName opts con contents
890909
910+#if MIN_VERSION_template_haskell(2,11,0)
911+-- GADTs. We ignore the refined return type and proceed as if it were a
912+-- NormalC or RecC.
913+parseArgs tName opts (GadtC conNames ts _) contents =
914+ parseArgs tName opts (NormalC (head conNames) ts) contents
915+
916+parseArgs tName opts (RecGadtC conNames ts _) contents =
917+ parseArgs tName opts (RecC (head conNames) ts) contents
918+#endif
919+
891920-- | Generates code to parse the JSON encoding of an n-ary
892921-- constructor.
893922parseProduct :: Name -- ^ Name of the type to which the constructor belongs.
@@ -1102,87 +1131,260 @@ buildTypeInstance :: Name
11021131 -> Maybe [Type]
11031132 -- ^ 'Just' the types used to instantiate a data family instance,
11041133 -- or 'Nothing' if it's a plain data type
1105− -> (Q Cxt, Q Type)
1134+ -> Q (Cxt, Type)
11061135 -- ^ The resulting 'Cxt' and 'Type' to use in a class instance
11071136-- Plain data type/newtype case
11081137buildTypeInstance tyConName constraint tvbs Nothing =
1109− (applyCon constraint typeNames, conT constraint `appT` instanceType)
1110− where
1111− typeNames :: [Name]
1112− typeNames = map tvbName tvbs
1113−
1114− instanceType :: Q Type
1115− instanceType = applyTyCon tyConName $ map varT typeNames
1138+ let varTys :: [Type]
1139+ varTys = map tvbToType tvbs
1140+ in buildTypeInstanceFromTys tyConName constraint varTys False
11161141-- Data family instance case
1117−buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) =
1118− (applyCon constraint lhsTvbNames, conT constraint `appT` instanceType)
1119− where
1120− -- We need to make sure that type variables in the instance head which have
1121− -- constraints aren't poly-kinded, e.g.,
1122− --
1123− -- @
1124− -- instance ToJSON a => ToJSON (Foo (a :: k)) where
1125− -- @
1126− --
1127− -- To do this, we remove every kind ascription (i.e., strip off every 'SigT').
1128− instanceType :: Q Type
1129− instanceType = applyTyCon dataFamName $ map (return . unSigT) rhsTypes
1130−
1131− -- We need to mindful of an old GHC bug which causes kind variables appear in
1132− -- @instTysAndKinds@ (as the name suggests) if (1) @PolyKinds@ is enabled, and
1133− -- (2) either GHC 7.6 or 7.8 is being used (for more info, see
1134− -- https://ghc.haskell.org/trac/ghc/ticket/9692).
1135− --
1136− -- Since Template Haskell doesn't seem to have a mechanism for detecting which
1137− -- language extensions are enabled, we do the next-best thing by counting
1138− -- the number of distinct kind variables in the data family declaration, and
1139− -- then dropping that number of entries from @instTysAndKinds@
1140− instTypes :: [Type]
1141− instTypes =
1142−#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0))
1143− instTysAndKinds
1142+--
1143+-- The CPP is present to work around a couple of annoying old GHC bugs.
1144+-- See Note [Polykinded data families in Template Haskell]
1145+buildTypeInstance dataFamName constraint tvbs (Just instTysAndKinds) = do
1146+#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)
1147+ let instTys :: [Type]
1148+ instTys = zipWith stealKindForType tvbs instTysAndKinds
11441149#else
1145− drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) tvbs)
1146− instTysAndKinds
1150+ let kindVarNames :: [Name]
1151+ kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs
1152+
1153+ -- Gets all of the type/kind variable names mentioned somewhere in a Type.
1154+ tyVarNamesOfType :: Type -> [Name]
1155+ tyVarNamesOfType = go
1156+ where
1157+ go :: Type -> [Name]
1158+ go (AppT t1 t2) = go t1 ++ go t2
1159+ go (SigT t k) = go t ++ go k
1160+ go (VarT n) = [n]
1161+ go _ = []
1162+
1163+ numKindVars :: Int
1164+ numKindVars = length kindVarNames
1165+
1166+ givenKinds, givenKinds' :: [Kind]
1167+ givenTys :: [Type]
1168+ (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds
1169+ givenKinds' = map sanitizeStars givenKinds
1170+
1171+ -- A GHC 7.6-specific bug requires us to replace all occurrences of
1172+ -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.
1173+ -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.
1174+ sanitizeStars :: Kind -> Kind
1175+ sanitizeStars = go
1176+ where
1177+ go :: Kind -> Kind
1178+ go (AppT t1 t2) = AppT (go t1) (go t2)
1179+ go (SigT t k) = SigT (go t) (go k)
1180+ go (ConT n) | n == starKindName = StarT
1181+ go t = t
1182+
1183+ -- It's quite awkward to import * from GHC.Prim, so we'll just
1184+ -- hack our way around it.
1185+ starKindName :: Name
1186+ starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"
1187+
1188+ -- Generate a list of fresh names with a common prefix, and numbered suffixes.
1189+ newNameList :: String -> Int -> Q [Name]
1190+ newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]
1191+
1192+ -- If we run this code with GHC 7.8, we might have to generate extra type
1193+ -- variables to compensate for any type variables that Template Haskell
1194+ -- eta-reduced away.
1195+ -- See Note [Polykinded data families in Template Haskell]
1196+ xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)
1197+
1198+ let xTys :: [Type]
1199+ xTys = map VarT xTypeNames
1200+ -- ^ Because these type variables were eta-reduced away, we can only
1201+ -- determine their kind by using stealKindForType. Therefore, we mark
1202+ -- them as VarT to ensure they will be given an explicit kind annotation
1203+ -- (and so the kind inference machinery has the right information).
1204+
1205+ substNameWithKind :: Name -> Kind -> Type -> Type
1206+ substNameWithKind n k = substType (M.singleton n k)
1207+
1208+ substNamesWithKinds :: [(Name, Kind)] -> Type -> Type
1209+ substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks
1210+
1211+ -- The types from the data family instance might not have explicit kind
1212+ -- annotations, which the kind machinery needs to work correctly. To
1213+ -- compensate, we use stealKindForType to explicitly annotate any
1214+ -- types without kind annotations.
1215+ instTys :: [Type]
1216+ instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))
1217+ -- ^ Note that due to a GHC 7.8-specific bug
1218+ -- (see Note [Polykinded data families in Template Haskell]),
1219+ -- there may be more kind variable names than there are kinds
1220+ -- to substitute. But this is OK! If a kind is eta-reduced, it
1221+ -- means that is was not instantiated to something more specific,
1222+ -- so we need not substitute it. Using stealKindForType will
1223+ -- grab the correct kind.
1224+ $ zipWith stealKindForType tvbs (givenTys ++ xTys)
11471225#endif
1226+ buildTypeInstanceFromTys dataFamName constraint instTys True
1227+
1228+-- For the given Types, generate an instance context and head.
1229+buildTypeInstanceFromTys :: Name
1230+ -- ^ The type constructor or data family name
1231+ -> Name
1232+ -- ^ The typeclass name ('ToJSON' or 'FromJSON')
1233+ -> [Type]
1234+ -- ^ The types to instantiate the instance with
1235+ -> Bool
1236+ -- ^ True if it's a data family, False otherwise
1237+ -> Q (Cxt, Type)
1238+buildTypeInstanceFromTys tyConName constraint varTysOrig isDataFamily = do
1239+ -- Make sure to expand through type/kind synonyms! Otherwise, we won't
1240+ -- be able to infer constraints as accurately.
1241+ varTysExp <- mapM expandSyn varTysOrig
1242+
1243+ let preds :: [Maybe Pred]
1244+ -- Derive instance constraints for type variables of kind *
1245+ preds = map (deriveConstraint constraint) varTysExp
1246+
1247+ varTys :: [Type]
1248+ -- See Note [Kind signatures in derived instances] for an explanation
1249+ -- of the isDataFamily check.
1250+ varTys =
1251+ if isDataFamily
1252+ then varTysOrig
1253+ else map unSigT varTysOrig
1254+
1255+ instanceCxt :: Cxt
1256+ instanceCxt = catMaybes preds
1257+
1258+ instanceType :: Type
1259+ instanceType = AppT (ConT constraint)
1260+ $ applyTyCon tyConName varTys
1261+
1262+ return (instanceCxt, instanceType)
1263+
1264+-- | Attempt to derive a constraint on a Type. If it's of kind *,
1265+-- we give it Just a ToJSON/FromJSON constraint. Otherwise, return Nothing.
1266+deriveConstraint :: Name -> Type -> Maybe Pred
1267+deriveConstraint constraint t
1268+ | isTyVar t && hasKindStar t = Just $ applyCon constraint $ varTToName t
1269+ | otherwise = Nothing
11481270
1149− lhsTvbNames :: [Name]
1150− lhsTvbNames = map (tvbName . uncurry replaceTyVarName)
1151− . filter (isTyVar . snd)
1152− $ zip tvbs rhsTypes
1153−
1154− -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable
1155− -- in @instTypes@ are provided (as a result of this bug:
1156− -- https://ghc.haskell.org/trac/ghc/ticket/9692). To work around this, we borrow
1157− -- some type variables from the data family instance declaration.
1158− rhsTypes :: [Type]
1159− rhsTypes =
1160−#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
1161− instTypes ++ map tvbToType
1162− (drop (length instTypes)
1163− tvbs)
1164−#else
1165− instTypes
1166−#endif
1271+{-
1272+Note [Polykinded data families in Template Haskell]
1273+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1274+
1275+In order to come up with the correct instance context and head for an instance, e.g.,
1276+
1277+ instance C a => C (Data a) where ...
1278+
1279+We need to know the exact types and kinds used to instantiate the instance. For
1280+plain old datatypes, this is simple: every type must be a type variable, and
1281+Template Haskell reliably tells us the type variables and their kinds.
1282+
1283+Doing the same for data families proves to be much harder for three reasons:
1284+
1285+1. On any version of Template Haskell, it may not tell you what an instantiated
1286+ type's kind is. For instance, in the following data family instance:
1287+
1288+ data family Fam (f :: * -> *) (a :: *)
1289+ data instance Fam f a
1290+
1291+ Then if we use TH's reify function, it would tell us the TyVarBndrs of the
1292+ data family declaration are:
1293+
1294+ [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]
1295+
1296+ and the instantiated types of the data family instance are:
11671297
1168−#if MIN_VERSION_template_haskell(2,8,0) && __GLASGOW_HASKELL__ < 710
1169−distinctKindVars :: Kind -> Set.Set Name
1170−distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2
1171−distinctKindVars (SigT k _) = distinctKindVars k
1172−distinctKindVars (VarT k) = Set.singleton k
1173−distinctKindVars _ = Set.empty
1298+ [VarT f1,VarT a1]
1299+
1300+ We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we
1301+ have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the
1302+ kind is in case an instantiated type isn't a SigT, so we use the stealKindForType
1303+ function to ensure all of the instantiated types are SigTs before passing them
1304+ to buildTypeInstanceFromTys.
1305+2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of
1306+ the specified kinds of a data family instance efore any of the instantiated
1307+ types. Fortunately, this is easy to deal with: you simply count the number of
1308+ distinct kind variables in the data family declaration, take that many elements
1309+ from the front of the Types list of the data family instance, substitute the
1310+ kind variables with their respective instantiated kinds (which you took earlier),
1311+ and proceed as normal.
1312+3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template
1313+ Haskell might not even list all of the Types of a data family instance, since
1314+ they are eta-reduced away! And yes, kinds can be eta-reduced too.
1315+
1316+ The simplest workaround is to count how many instantiated types are missing from
1317+ the list and generate extra type variables to use in their place. Luckily, we
1318+ needn't worry much if its kind was eta-reduced away, since using stealKindForType
1319+ will get it back.
1320+
1321+Note [Kind signatures in derived instances]
1322+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1323+
1324+It is possible to put explicit kind signatures into the derived instances, e.g.,
1325+
1326+ instance C a => C (Data (f :: * -> *)) where ...
1327+
1328+But it is preferable to avoid this if possible. If we come up with an incorrect
1329+kind signature (which is entirely possible, since Template Haskell doesn't always
1330+have the best track record with reifying kind signatures), then GHC will flat-out
1331+reject the instance, which is quite unfortunate.
1332+
1333+Plain old datatypes have the advantage that you can avoid using any kind signatures
1334+at all in their instances. This is because a datatype declaration uses all type
1335+variables, so the types that we use in a derived instance uniquely determine their
1336+kinds. As long as we plug in the right types, the kind inferencer can do the rest
1337+of the work. For this reason, we use unSigT to remove all kind signatures before
1338+splicing in the instance context and head.
1339+
1340+Data family instances are trickier, since a data family can have two instances that
1341+are distinguished by kind alone, e.g.,
1342+
1343+ data family Fam (a :: k)
1344+ data instance Fam (a :: * -> *)
1345+ data instance Fam (a :: *)
1346+
1347+If we dropped the kind signatures for C (Fam a), then GHC will have no way of
1348+knowing which instance we are talking about. To avoid this scenario, we always
1349+include explicit kind signatures in data family instances. There is a chance that
1350+the inferred kind signatures will be incorrect, but if so, we can always fall back
1351+on the mk- functions.
1352+-}
1353+
1354+-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.
1355+stealKindForType :: TyVarBndr -> Type -> Type
1356+stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb)
1357+stealKindForType _ t = t
11741358
11751359-- | Extracts the kind from a type variable binder.
11761360tvbKind :: TyVarBndr -> Kind
1177−tvbKind (PlainTV _ ) = starK
1178−tvbKind (KindedTV _ k) = k
1361+#if MIN_VERSION_template_haskell(2,8,0)
1362+tvbKind (PlainTV _ ) = StarT
1363+#else
1364+tvbKind (PlainTV _ ) = StarK
11791365#endif
1366+tvbKind (KindedTV _ k) = k
11801367
1181−#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710
11821368tvbToType :: TyVarBndr -> Type
11831369tvbToType (PlainTV n) = VarT n
11841370tvbToType (KindedTV n k) = SigT (VarT n) k
1371+
1372+-- | Returns True if a Type has kind *.
1373+hasKindStar :: Type -> Bool
1374+hasKindStar VarT{} = True
1375+#if MIN_VERSION_template_haskell(2,8,0)
1376+hasKindStar (SigT _ StarT) = True
1377+#else
1378+hasKindStar (SigT _ StarK) = True
11851379#endif
1380+hasKindStar _ = False
1381+
1382+-- | Extract the Name from a type variable. If the argument Type is not a
1383+-- type variable, throw an error.
1384+varTToName :: Type -> Name
1385+varTToName (VarT n) = n
1386+varTToName (SigT t _) = varTToName t
1387+varTToName _ = error "Not a type variable!"
11861388
11871389-- | Extracts the name from a constructor.
11881390getConName :: Con -> Name
@@ -1190,22 +1392,14 @@ getConName (NormalC name _) = name
11901392getConName (RecC name _) = name
11911393getConName (InfixC _ name _) = name
11921394getConName (ForallC _ _ con) = getConName con
1193−
1194−-- | Extracts the name from a type variable binder.
1195−tvbName :: TyVarBndr -> Name
1196−tvbName (PlainTV name ) = name
1197−tvbName (KindedTV name _) = name
1198−
1199−-- | Replace the Name of a TyVarBndr with one from a Type (if the Type has a Name).
1200−replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr
1201−replaceTyVarName tvb (SigT t _) = replaceTyVarName tvb t
1202−replaceTyVarName (PlainTV _) (VarT n) = PlainTV n
1203−replaceTyVarName (KindedTV _ k) (VarT n) = KindedTV n k
1204−replaceTyVarName tvb _ = tvb
1395+#if MIN_VERSION_template_haskell(2,11,0)
1396+getConName (GadtC names _ _) = head names
1397+getConName (RecGadtC names _ _) = head names
1398+#endif
12051399
12061400-- | Fully applies a type constructor to its type variables.
1207−applyTyCon :: Name -> [Q Type] -> Q Type
1208−applyTyCon = foldl' appT . conT
1401+applyTyCon :: Name -> [Type] -> Type
1402+applyTyCon = foldl' AppT . ConT
12091403
12101404-- | Is the given type a variable?
12111405isTyVar :: Type -> Bool
@@ -1241,11 +1435,71 @@ valueConName (Number _) = "Number"
12411435valueConName (Bool _) = "Boolean"
12421436valueConName Null = "Null"
12431437
1244−applyCon :: Name -> [Name] -> Q [Pred]
1245−applyCon con typeNames = return (map apply typeNames)
1246− where apply t =
1438+applyCon :: Name -> Name -> Pred
1439+applyCon con t =
12471440#if MIN_VERSION_template_haskell(2,10,0)
12481441 AppT (ConT con) (VarT t)
12491442#else
12501443 ClassP con [VarT t]
12511444#endif
1445+
1446+-------------------------------------------------------------------------------
1447+-- Expanding type synonyms
1448+-------------------------------------------------------------------------------
1449+
1450+-- | Expands all type synonyms in a type. Written by Dan Rosén in the
1451+-- @genifunctors@ package (licensed under BSD3).
1452+expandSyn :: Type -> Q Type
1453+expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t
1454+expandSyn t@AppT{} = expandSynApp t []
1455+expandSyn t@ConT{} = expandSynApp t []
1456+expandSyn (SigT t k) = do t' <- expandSyn t
1457+ k' <- expandSynKind k
1458+ return (SigT t' k')
1459+expandSyn t = return t
1460+
1461+expandSynKind :: Kind -> Q Kind
1462+#if MIN_VERSION_template_haskell(2,8,0)
1463+expandSynKind = expandSyn
1464+#else
1465+expandSynKind = return -- There are no kind synonyms to deal with
1466+#endif
1467+
1468+expandSynApp :: Type -> [Type] -> Q Type
1469+expandSynApp (AppT t1 t2) ts = do
1470+ t2' <- expandSyn t2
1471+ expandSynApp t1 (t2':ts)
1472+expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts
1473+expandSynApp t@(ConT n) ts = do
1474+ info <- reify n
1475+ case info of
1476+ TyConI (TySynD _ tvs rhs) ->
1477+ let (ts', ts'') = splitAt (length tvs) ts
1478+ subs = mkSubst tvs ts'
1479+ rhs' = substType subs rhs
1480+ in expandSynApp rhs' ts''
1481+ _ -> return $ foldl' AppT t ts
1482+expandSynApp t ts = do
1483+ t' <- expandSyn t
1484+ return $ foldl' AppT t' ts
1485+
1486+type TypeSubst = Map Name Type
1487+
1488+mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst
1489+mkSubst vs ts =
1490+ let vs' = map un vs
1491+ un (PlainTV v) = v
1492+ un (KindedTV v _) = v
1493+ in M.fromList $ zip vs' ts
1494+
1495+substType :: TypeSubst -> Type -> Type
1496+substType subs (ForallT v c t) = ForallT v c $ substType subs t
1497+substType subs t@(VarT n) = M.findWithDefault t n subs
1498+substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)
1499+substType subs (SigT t k) = SigT (substType subs t)
1500+#if MIN_VERSION_template_haskell(2,8,0)
1501+ (substType subs k)
1502+#else
1503+ k
1504+#endif
1505+substType _ t = t