th-abstraction 0.2.11.0 → 0.3.0.0
raw patch · 5 files changed
+709/−313 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.Haskell.TH.Datatype: [datatypeInstTypes] :: DatatypeInfo -> [Type]
- Language.Haskell.TH.Datatype: DatatypeInfo :: Cxt -> Name -> [Type] -> DatatypeVariant -> [ConstructorInfo] -> DatatypeInfo
+ Language.Haskell.TH.Datatype: DatatypeInfo :: Cxt -> Name -> [TyVarBndr] -> [Type] -> DatatypeVariant -> [ConstructorInfo] -> DatatypeInfo
- Language.Haskell.TH.Datatype: [datatypeVars] :: DatatypeInfo -> [Type]
+ Language.Haskell.TH.Datatype: [datatypeVars] :: DatatypeInfo -> [TyVarBndr]
- Language.Haskell.TH.Datatype: normalizeCon :: Name -> [Type] -> DatatypeVariant -> Con -> Q [ConstructorInfo]
+ Language.Haskell.TH.Datatype: normalizeCon :: Name -> [TyVarBndr] -> [Type] -> DatatypeVariant -> Con -> Q [ConstructorInfo]
- Language.Haskell.TH.Datatype: tySynInstDCompat :: Name -> [TypeQ] -> TypeQ -> DecQ
+ Language.Haskell.TH.Datatype: tySynInstDCompat :: Name -> Maybe [Q TyVarBndr] -> [TypeQ] -> TypeQ -> DecQ
Files
- ChangeLog.md +15/−0
- src/Language/Haskell/TH/Datatype.hs +369/−126
- test/Harness.hs +38/−30
- test/Main.hs +284/−154
- th-abstraction.cabal +3/−3
ChangeLog.md view
@@ -1,5 +1,20 @@ # Revision history for th-abstraction +## 0.3.0.0 -- 2019-04-26+* Breaking change: the `datatypeVars` field of `DatatypeInfo` is now of type+ `[TyVarBndr]` instead of `[Type]`, as it now refers to all of the bound type+ variables in the data type. The old `datatypeVars` field has been renamed to+ `datatypeInstTypes` to better reflect its purpose.++ In addition, the type of `normalizeCon` now has an additional `[TyVarBndr]`+ argument, since `DatatypeInfo` now requires it.+* Support `template-haskell-2.15`.+* Fix a bug in which `normalizeDec` would not detect existential type variables+ in a GADT constructor if they were implicitly quantified.+* Fix a bug in which `normalizeDec` would report an incorrect number of+ `datatypeVars` for GADT declarations with explicit return kinds (such as+ `data Foo :: * -> * where`).+ ## 0.2.11.0 -- 2019-02-26 * Fix a bug in which `freeVariablesWellScoped` would sometimes not preserve the left-to-right ordering of `Name`s generated with `newName`.
src/Language/Haskell/TH/Datatype.hs view
@@ -20,11 +20,12 @@ @ 'DatatypeInfo'- { 'datatypeContext' = []- , 'datatypeName' = GHC.Base.Maybe- , 'datatypeVars' = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ]- , 'datatypeVariant' = 'Datatype'- , 'datatypeCons' =+ { 'datatypeContext' = []+ , 'datatypeName' = GHC.Base.Maybe+ , 'datatypeVars' = [ 'KindedTV' a_3530822107858468866 'StarT' ]+ , 'datatypeInstTypes' = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ]+ , 'datatypeVariant' = 'Datatype'+ , 'datatypeCons' = [ 'ConstructorInfo' { 'constructorName' = GHC.Base.Nothing , 'constructorVars' = []@@ -145,16 +146,51 @@ -- | Normalized information about newtypes and data types. ----- 'datatypeVars' types will have an outermost 'SigT' to indicate the--- parameter's kind. These types will be simple variables for /ADT/s--- declared with @data@ and @newtype@, but can be more complex for--- types declared with @data instance@ and @newtype instance@.+-- 'DatatypeInfo' contains two fields, 'datatypeVars' and 'datatypeInstTypes',+-- which encode information about the argument types. The simplest explanation+-- is that 'datatypeVars' contains all the type /variables/ bound by the data+-- type constructor, while 'datatypeInstTypes' contains the type /arguments/+-- to the data type constructor. To be more precise:+--+-- * For ADTs declared with @data@ and @newtype@, it will likely be the case+-- that 'datatypeVars' and 'datatypeInstTypes' coincide. For instance, given+-- @newtype Id a = MkId a@, in the 'DatatypeInfo' for @Id@ we would+-- have @'datatypeVars' = ['KindedTV' a 'StarT']@ and+-- @'datatypeInstVars' = ['SigT' ('VarT' a) 'StarT']@.+--+-- ADTs that leverage @PolyKinds@ may have more 'datatypeVars' than+-- 'datatypeInstTypes'. For instance, given @data Proxy (a :: k) = MkProxy@,+-- in the 'DatatypeInfo' for @Proxy@ we would have+-- @'datatypeVars' = ['KindedTV' k 'StarT', 'KindedTV' a ('VarT' k)]@ (since+-- there are two variables, @k@ and @a@), whereas+-- @'datatypeInstTypes' = ['SigT' ('VarT' a) ('VarT' k)]@, since there is+-- only one explicit type argument to @Proxy@.+--+-- * For @data instance@s and @newtype instance@s of data families,+-- 'datatypeVars' and 'datatypeInstTypes' can be quite different. Here is+-- an example to illustrate the difference:+--+-- @+-- data family F a b+-- data instance F (Maybe c) (f x) = MkF c (f x)+-- @+--+-- Then in the 'DatatypeInfo' for @F@'s data instance, we would have:+--+-- @+-- 'datatypeVars' = [ 'KindedTV' c 'StarT'+-- , 'KindedTV' f 'StarT'+-- , 'KindedTV' x 'StarT' ]+-- 'datatypeInstTypes' = [ 'AppT' ('ConT' ''Maybe) ('VarT' c)+-- , 'AppT' ('VarT' f) ('VarT' x) ]+-- @ data DatatypeInfo = DatatypeInfo- { datatypeContext :: Cxt -- ^ Data type context (deprecated)- , datatypeName :: Name -- ^ Type constructor- , datatypeVars :: [Type] -- ^ Type parameters- , datatypeVariant :: DatatypeVariant -- ^ Extra information- , datatypeCons :: [ConstructorInfo] -- ^ Normalize constructor information+ { datatypeContext :: Cxt -- ^ Data type context (deprecated)+ , datatypeName :: Name -- ^ Type constructor+ , datatypeVars :: [TyVarBndr] -- ^ Type parameters+ , datatypeInstTypes :: [Type] -- ^ Argument types+ , datatypeVariant :: DatatypeVariant -- ^ Extra information+ , datatypeCons :: [ConstructorInfo] -- ^ Normalize constructor information } deriving (Show, Eq, Typeable, Data #ifdef HAS_GENERICS@@ -270,7 +306,7 @@ datatypeType di = foldl AppT (ConT (datatypeName di)) $ map stripSigT- $ datatypeVars di+ $ datatypeInstTypes di -- | Compute a normalized view of the metadata about a data type or newtype@@ -411,7 +447,7 @@ reifyRecordType :: Name -> Type -> Q DatatypeInfo reifyRecordType recName recTy =- let (_, argTys :|- _) = uncurryType recTy+ let (_, _, argTys :|- _) = uncurryType recTy in case argTys of dataTy:_ -> decomposeDataType dataTy _ -> notRecSelFailure@@ -525,8 +561,22 @@ DataInstD cx n (repairVarKindsWith' dvars ts) cons deriv #else repairDataFam famD instD-# if MIN_VERSION_template_haskell(2,11,0)+# if MIN_VERSION_template_haskell(2,15,0) | DataFamilyD _ dvars _ <- famD+ , NewtypeInstD cx mbInstVars nts k c deriv <- instD+ , con :| ts <- decomposeType nts+ = NewtypeInstD cx mbInstVars+ (foldl' AppT con (repairVarKindsWith (fromMaybe dvars mbInstVars) ts))+ k c deriv++ | DataFamilyD _ dvars _ <- famD+ , DataInstD cx mbInstVars nts k c deriv <- instD+ , con :| ts <- decomposeType nts+ = DataInstD cx mbInstVars+ (foldl' AppT con (repairVarKindsWith (fromMaybe dvars mbInstVars) ts))+ k c deriv+# elif MIN_VERSION_template_haskell(2,11,0)+ | DataFamilyD _ dvars _ <- famD , NewtypeInstD cx n ts k c deriv <- instD = NewtypeInstD cx n (repairVarKindsWith dvars ts) k c deriv @@ -577,44 +627,128 @@ normalizeDecFor isReified dec = case dec of #if MIN_VERSION_template_haskell(2,12,0)- NewtypeD context name tyvars _kind con _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) [con] Newtype- DataD context name tyvars _kind cons _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) cons Datatype- NewtypeInstD context name params _kind con _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params [con] NewtypeInstance- DataInstD context name params _kind cons _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params cons DataInstance+ NewtypeD context name tyvars mbKind con _derives ->+ normalizeDataD context name tyvars mbKind [con] Newtype+ DataD context name tyvars mbKind cons _derives ->+ normalizeDataD context name tyvars mbKind cons Datatype+# if MIN_VERSION_template_haskell(2,15,0)+ NewtypeInstD context mbTyvars nameInstTys mbKind con _derives ->+ normalizeDataInstDPostTH2'15 "newtype" context mbTyvars nameInstTys+ mbKind [con] NewtypeInstance+ DataInstD context mbTyvars nameInstTys mbKind cons _derives ->+ normalizeDataInstDPostTH2'15 "data" context mbTyvars nameInstTys+ mbKind cons DataInstance+# else+ NewtypeInstD context name instTys mbKind con _derives ->+ normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance+ DataInstD context name instTys mbKind cons _derives ->+ normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance+# endif #elif MIN_VERSION_template_haskell(2,11,0)- NewtypeD context name tyvars _kind con _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) [con] Newtype- DataD context name tyvars _kind cons _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) cons Datatype- NewtypeInstD context name params _kind con _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params [con] NewtypeInstance- DataInstD context name params _kind cons _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params cons DataInstance+ NewtypeD context name tyvars mbKind con _derives ->+ normalizeDataD context name tyvars mbKind [con] Newtype+ DataD context name tyvars mbKind cons _derives ->+ normalizeDataD context name tyvars mbKind cons Datatype+ NewtypeInstD context name instTys mbKind con _derives ->+ normalizeDataInstDPreTH2'15 context name instTys mbKind [con] NewtypeInstance+ DataInstD context name instTys mbKind cons _derives ->+ normalizeDataInstDPreTH2'15 context name instTys mbKind cons DataInstance #else NewtypeD context name tyvars con _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) [con] Newtype+ normalizeDataD context name tyvars Nothing [con] Newtype DataD context name tyvars cons _derives ->- giveTypesStarKinds <$> normalizeDec' isReified context name (bndrParams tyvars) cons Datatype- NewtypeInstD context name params con _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params [con] NewtypeInstance- DataInstD context name params cons _derives ->- repair13618' . giveTypesStarKinds =<<- normalizeDec' isReified context name params cons DataInstance+ normalizeDataD context name tyvars Nothing cons Datatype+ NewtypeInstD context name instTys con _derives ->+ normalizeDataInstDPreTH2'15 context name instTys Nothing [con] NewtypeInstance+ DataInstD context name instTys cons _derives ->+ normalizeDataInstDPreTH2'15 context name instTys Nothing cons DataInstance #endif _ -> fail "normalizeDecFor: DataD or NewtypeD required" where- repair13618' | isReified = repair13618- | otherwise = return+ -- We only need to repair reified declarations for data family instances.+ repair13618' :: DatatypeInfo -> Q DatatypeInfo+ repair13618' di@DatatypeInfo{datatypeVariant = variant}+ | isReified && isFamInstVariant variant+ = repair13618 di+ | otherwise+ = return di + -- Given a data type's instance types and kind, compute its free variables.+ datatypeFreeVars :: [Type] -> Maybe Kind -> [TyVarBndr]+ datatypeFreeVars instTys mbKind =+ freeVariablesWellScoped $ instTys +++#if MIN_VERSION_template_haskell(2,8,0)+ maybeToList mbKind+#else+ [] -- No kind variables+#endif++ normalizeDataD :: Cxt -> Name -> [TyVarBndr] -> Maybe Kind+ -> [Con] -> DatatypeVariant -> Q DatatypeInfo+ normalizeDataD context name tyvars mbKind cons variant =+ let params = bndrParams tyvars in+ normalize' context name (datatypeFreeVars params mbKind)+ params mbKind cons variant++ normalizeDataInstDPostTH2'15+ :: String -> Cxt -> Maybe [TyVarBndr] -> Type -> Maybe Kind+ -> [Con] -> DatatypeVariant -> Q DatatypeInfo+ normalizeDataInstDPostTH2'15 what context mbTyvars nameInstTys+ mbKind cons variant =+ case decomposeType nameInstTys of+ ConT name :| instTys ->+ normalize' context name+ (fromMaybe (datatypeFreeVars instTys mbKind) mbTyvars)+ instTys mbKind cons variant+ _ -> fail $ "Unexpected " ++ what ++ " instance head: " ++ pprint nameInstTys++ normalizeDataInstDPreTH2'15+ :: Cxt -> Name -> [Type] -> Maybe Kind+ -> [Con] -> DatatypeVariant -> Q DatatypeInfo+ normalizeDataInstDPreTH2'15 context name instTys mbKind cons variant =+ normalize' context name (datatypeFreeVars instTys mbKind)+ instTys mbKind cons variant++ -- The main worker of this function.+ normalize' :: Cxt -> Name -> [TyVarBndr] -> [Type] -> Maybe Kind+ -> [Con] -> DatatypeVariant -> Q DatatypeInfo+ normalize' context name tvbs instTys mbKind cons variant = do+ extra_tvbs <- mkExtraKindBinders $ fromMaybe starK mbKind+ let tvbs' = tvbs ++ extra_tvbs+ instTys' = instTys ++ bndrParams extra_tvbs+ dec <- normalizeDec' isReified context name tvbs' instTys' cons variant+ repair13618' $ giveDIVarsStarKinds dec++-- | Create new kind variable binder names corresponding to the return kind of+-- a data type. This is useful when you have a data type like:+--+-- @+-- data Foo :: forall k. k -> Type -> Type where ...+-- @+--+-- But you want to be able to refer to the type @Foo a b@.+-- 'mkExtraKindBinders' will take the kind @forall k. k -> Type -> Type@,+-- discover that is has two visible argument kinds, and return as a result+-- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@+-- are fresh type variable names.+--+-- This expands kind synonyms if necessary.+mkExtraKindBinders :: Kind -> Q [TyVarBndr]+mkExtraKindBinders kind = do+ kind' <- resolveKindSynonyms kind+ let (_, _, args :|- _) = uncurryKind kind'+ names <- replicateM (length args) (newName "x")+ return $ zipWith KindedTV names args++-- | Is a declaration for a @data instance@ or @newtype instance@?+isFamInstVariant :: DatatypeVariant -> Bool+isFamInstVariant dv =+ case dv of+ Datatype -> False+ Newtype -> False+ DataInstance -> True+ NewtypeInstance -> True+ bndrParams :: [TyVarBndr] -> [Type] bndrParams = map $ \bndr -> case bndr of@@ -636,18 +770,20 @@ IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> Cxt {- ^ Datatype context -} -> Name {- ^ Type constructor -} ->- [Type] {- ^ Type parameters -} ->+ [TyVarBndr] {- ^ Type parameters -} ->+ [Type] {- ^ Argument types -} -> [Con] {- ^ Constructors -} -> DatatypeVariant {- ^ Extra information -} -> Q DatatypeInfo-normalizeDec' reifiedDec context name params cons variant =- do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params variant) cons+normalizeDec' reifiedDec context name params instTys cons variant =+ do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params instTys variant) cons return DatatypeInfo- { datatypeContext = context- , datatypeName = name- , datatypeVars = params- , datatypeCons = cons'- , datatypeVariant = variant+ { datatypeContext = context+ , datatypeName = name+ , datatypeVars = params+ , datatypeInstTypes = instTys+ , datatypeCons = cons'+ , datatypeVariant = variant } -- | Normalize a 'Con' into a 'ConstructorInfo'. This requires knowledge of@@ -656,7 +792,8 @@ -- 'Dec'. normalizeCon :: Name {- ^ Type constructor -} ->- [Type] {- ^ Type parameters -} ->+ [TyVarBndr] {- ^ Type parameters -} ->+ [Type] {- ^ Argument types -} -> DatatypeVariant {- ^ Extra information -} -> Con {- ^ Constructor -} -> Q [ConstructorInfo]@@ -665,11 +802,13 @@ normalizeConFor :: IsReifiedDec {- ^ Is this a reified 'Dec'? -} -> Name {- ^ Type constructor -} ->- [Type] {- ^ Type parameters -} ->+ [TyVarBndr] {- ^ Type parameters -} ->+ [Type] {- ^ Argument types -} -> DatatypeVariant {- ^ Extra information -} -> Con {- ^ Constructor -} -> Q [ConstructorInfo]-normalizeConFor reifiedDec typename params variant = fmap (map giveTyVarBndrsStarKinds) . dispatch+normalizeConFor reifiedDec typename params instTys variant =+ fmap (map giveCIVarsStarKinds) . dispatch where -- A GADT constructor is declared infix when: --@@ -756,7 +895,7 @@ gadtCase ns innerType (takeFieldTypes xs) stricts (const $ return $ RecordConstructor fns) where- gadtCase = normalizeGadtC typename params tyvars context+ gadtCase = normalizeGadtC typename params instTys tyvars context #endif #if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0)) dataFamCompatCase :: Con -> Q [ConstructorInfo]@@ -766,37 +905,37 @@ case c of NormalC n xs -> let stricts = map (normalizeStrictness . fst) xs in- dataFamCase' n tyvars stricts NormalConstructor+ dataFamCase' n stricts NormalConstructor InfixC l n r -> let stricts = map (normalizeStrictness . fst) [l,r] in- dataFamCase' n tyvars stricts InfixConstructor+ dataFamCase' n stricts InfixConstructor RecC n xs -> let stricts = takeFieldStrictness xs in- dataFamCase' n tyvars stricts+ dataFamCase' n stricts (RecordConstructor (takeFieldNames xs)) ForallC tyvars' context' c' -> go (tyvars'++tyvars) c' - dataFamCase' :: Name -> [TyVarBndr] -> [FieldStrictness]+ dataFamCase' :: Name -> [FieldStrictness] -> ConstructorVariant -> Q [ConstructorInfo]- dataFamCase' n tyvars stricts variant = do+ dataFamCase' n stricts variant = do mbInfo <- reifyMaybe n case mbInfo of Just (DataConI _ ty _ _) -> do- let (context, argTys :|- returnTy) = uncurryType ty+ let (tyvars, context, argTys :|- returnTy) = uncurryType ty returnTy' <- resolveTypeSynonyms returnTy- -- Notice that we've ignored the Cxt and argument Types from the- -- Con argument above, as they might be scoped over eta-reduced- -- variables. Instead of trying to figure out what the- -- eta-reduced variables should be substituted with post facto,- -- we opt for the simpler approach of using the context and- -- argument types from the reified constructor Info, which will- -- at least be correctly scoped. This will make the task of- -- substituting those types with the variables we put in- -- place of the eta-reduced variables (in normalizeDec)- -- much easier.- normalizeGadtC typename params tyvars context [n]+ -- Notice that we've ignored the TyVarBndrs, Cxt and argument+ -- Types from the Con argument above, as they might be scoped+ -- over eta-reduced variables. Instead of trying to figure out+ -- what the eta-reduced variables should be substituted with+ -- post facto, we opt for the simpler approach of using the+ -- context and argument types from the reified constructor+ -- Info, which will at least be correctly scoped. This will+ -- make the task of substituting those types with the variables+ -- we put in place of the eta-reduced variables+ -- (in normalizeDec) much easier.+ normalizeGadtC typename params instTys tyvars context [n] returnTy' argTys stricts (const $ return variant) _ -> fail $ unlines [ "normalizeCon: Cannot reify constructor " ++ nameBase n@@ -841,10 +980,10 @@ -- needs to be performed to work around an old bug that eta-reduces the -- type patterns of data families (but only for reified data family instances). DataInstance- | reifiedDec, mightHaveBeenEtaReduced params+ | reifiedDec, mightHaveBeenEtaReduced instTys -> dataFamCompatCase NewtypeInstance- | reifiedDec, mightHaveBeenEtaReduced params+ | reifiedDec, mightHaveBeenEtaReduced instTys -> dataFamCompatCase _ -> defaultCase #else@@ -877,7 +1016,8 @@ normalizeGadtC :: Name {- ^ Type constructor -} ->- [Type] {- ^ Type parameters -} ->+ [TyVarBndr] {- ^ Type parameters -} ->+ [Type] {- ^ Argument types -} -> [TyVarBndr] {- ^ Constructor parameters -} -> Cxt {- ^ Constructor context -} -> [Name] {- ^ Constructor names -} ->@@ -888,16 +1028,29 @@ {- ^ Determine a constructor variant from its 'Name' -} -> Q [ConstructorInfo]-normalizeGadtC typename params tyvars context names innerType+normalizeGadtC typename params instTys tyvars context names innerType fields stricts getVariant =- do -- Due to GHC Trac #13885, it's possible that the type variables bound by+ do -- It's possible that the constructor has implicitly quantified type+ -- variables, such as in the following example (from #58):+ --+ -- [d| data Foo where+ -- MkFoo :: a -> Foo |]+ --+ -- normalizeGadtC assumes that all type variables have binders, however,+ -- so we use freeVariablesWellScoped to obtain the implicit type+ -- variables' binders before proceeding.+ let implicitTyvars = freeVariablesWellScoped+ [curryType tyvars context fields innerType]+ allTyvars = implicitTyvars ++ tyvars++ -- Due to GHC Trac #13885, it's possible that the type variables bound by -- a GADT constructor will shadow those that are bound by the data type. -- This function assumes this isn't the case in certain parts (e.g., when -- mergeArguments is invoked), so we do an alpha-renaming of the -- constructor-bound variables before proceeding. See #36 for an example -- of what can go wrong if this isn't done. let conBoundNames =- concatMap (\tvb -> tvName tvb:freeVariables (tvKind tvb)) tyvars+ concatMap (\tvb -> tvName tvb:freeVariables (tvKind tvb)) allTyvars conSubst <- T.sequence $ Map.fromList [ (n, newName (nameBase n)) | n <- conBoundNames ] let conSubst' = fmap VarT conSubst@@ -905,7 +1058,7 @@ map (\tvb -> case tvb of PlainTV n -> PlainTV (conSubst Map.! n) KindedTV n k -> KindedTV (conSubst Map.! n)- (applySubstitution conSubst' k)) tyvars+ (applySubstitution conSubst' k)) allTyvars renamedContext = applySubstitution conSubst' context renamedInnerType = applySubstitution conSubst' innerType renamedFields = applySubstitution conSubst' fields@@ -916,8 +1069,8 @@ let (substName, context1) = closeOverKinds (kindsOfFVsOfTvbs renamedTyvars)- (kindsOfFVsOfTypes params)- (mergeArguments params ts)+ (kindsOfFVsOfTvbs params)+ (mergeArguments instTys ts) subst = VarT <$> substName exTyvars = [ tv | tv <- renamedTyvars, Map.notMember (tvName tv) subst ] @@ -1094,10 +1247,10 @@ -- Note that this function will drop parentheses as a side effect. resolveTypeSynonyms :: Type -> Q Type resolveTypeSynonyms t =- let f :| xs = decomposeType t+ let (f, xs) = decomposeTypeArgs t notTypeSynCase :: Type -> Q Type- notTypeSynCase ty = foldl AppT ty <$> mapM resolveTypeSynonyms xs+ notTypeSynCase ty = foldl appTypeArg ty <$> mapM resolveTypeArgSynonyms xs expandCon :: Name -- The Name to check whether it is a type synonym or not -> Type -- The argument type to fall back on if the supplied@@ -1107,7 +1260,7 @@ mbInfo <- reifyMaybe n case mbInfo of Just (TyConI (TySynD _ synvars def))- -> resolveTypeSynonyms $ expandSynonymRHS synvars xs def+ -> resolveTypeSynonyms $ expandSynonymRHS synvars (filterTANormals xs) def _ -> notTypeSynCase ty in case f of@@ -1130,8 +1283,17 @@ t2' <- resolveTypeSynonyms t2 expandCon n (UInfixT t1' n t2') #endif+#if MIN_VERSION_template_haskell(2,15,0)+ ImplicitParamT n t -> do+ ImplicitParamT n `fmap` resolveTypeSynonyms t+#endif _ -> notTypeSynCase f +-- | Expand all of the type synonyms in a 'TypeArg'.+resolveTypeArgSynonyms :: TypeArg -> Q TypeArg+resolveTypeArgSynonyms (TANormal t) = TANormal <$> resolveTypeSynonyms t+resolveTypeArgSynonyms (TyArg k) = TyArg <$> resolveKindSynonyms k+ -- | Expand all of the type synonyms in a 'Kind'. resolveKindSynonyms :: Kind -> Q Kind #if MIN_VERSION_template_haskell(2,8,0)@@ -1193,21 +1355,57 @@ #endif -- | Decompose a type into a list of it's outermost applications. This process--- forgets about infix application and explicit parentheses.+-- forgets about infix application, explicit parentheses, and visible kind+-- applications. -- -- This operation should be used after all 'UInfixT' cases have been resolved -- by 'resolveFixities' if the argument is being user generated. -- -- > t ~= foldl1 AppT (decomposeType t) decomposeType :: Type -> NonEmpty Type-decomposeType = go []+decomposeType t =+ case decomposeTypeArgs t of+ (f, x) -> f :| filterTANormals x++-- | A variant of 'decomposeType' that preserves information about visible kind+-- applications by returning a 'NonEmpty' list of 'TypeArg's.+decomposeTypeArgs :: Type -> (Type, [TypeArg])+decomposeTypeArgs = go [] where- go args (AppT f x) = go (x:args) f+ go :: [TypeArg] -> Type -> (Type, [TypeArg])+ go args (AppT f x) = go (TANormal x:args) f #if MIN_VERSION_template_haskell(2,11,0)- go args (ParensT t) = go args t+ go args (ParensT t) = go args t #endif- go args t = t :| args+#if MIN_VERSION_template_haskell(2,15,0)+ go args (AppKindT f x) = go (TyArg x:args) f+#endif+ go args t = (t, args) +-- | An argument to a type, either a normal type ('TANormal') or a visible+-- kind application ('TyArg').+data TypeArg+ = TANormal Type+ | TyArg Kind++-- | Apply a 'Type' to a 'TypeArg'.+appTypeArg :: Type -> TypeArg -> Type+appTypeArg f (TANormal x) = f `AppT` x+appTypeArg f (TyArg _k) =+#if MIN_VERSION_template_haskell(2,15,0)+ f `AppKindT` _k+#else+ f -- VKA isn't supported, so conservatively drop the argument+#endif++-- | Filter out all of the normal type arguments from a list of 'TypeArg's.+filterTANormals :: [TypeArg] -> [Type]+filterTANormals = mapMaybe f+ where+ f :: TypeArg -> Maybe Type+ f (TANormal t) = Just t+ f (TyArg {}) = Nothing+ -- 'NonEmpty' didn't move into base until recently. Reimplementing it locally -- saves dependencies for supporting older GHCs data NonEmpty a = a :| [a]@@ -1215,20 +1413,44 @@ data NonEmptySnoc a = [a] :|- a -- Decompose a function type into its context, argument types,--- and return types. For instance, this+-- and return type. For instance, this ----- (Show a, b ~ Int) => (a -> b) -> Char -> Int+-- forall a b. (Show a, b ~ Int) => (a -> b) -> Char -> Int -- -- becomes ----- ([Show a, b ~ Int], [a -> b, Char] :|- Int)-uncurryType :: Type -> (Cxt, NonEmptySnoc Type)-uncurryType = go [] []+-- ([a, b], [Show a, b ~ Int], [a -> b, Char] :|- Int)+uncurryType :: Type -> ([TyVarBndr], Cxt, NonEmptySnoc Type)+uncurryType = go [] [] [] where- go ctxt args (AppT (AppT ArrowT t1) t2) = go ctxt (t1:args) t2- go ctxt args (ForallT _ ctxt' t) = go (ctxt++ctxt') args t- go ctxt args t = (ctxt, reverse args :|- t)+ go tvbs ctxt args (AppT (AppT ArrowT t1) t2) = go tvbs ctxt (t1:args) t2+ go tvbs ctxt args (ForallT tvbs' ctxt' t) = go (tvbs++tvbs') (ctxt++ctxt') args t+ go tvbs ctxt args t = (tvbs, ctxt, reverse args :|- t) +-- | Decompose a function kind into its context, argument kinds,+-- and return kind. For instance, this+--+-- forall a b. Maybe a -> Maybe b -> Type+--+-- becomes+--+-- ([a, b], [], [Maybe a, Maybe b] :|- Type)+uncurryKind :: Kind -> ([TyVarBndr], Cxt, NonEmptySnoc Kind)+#if MIN_VERSION_template_haskell(2,8,0)+uncurryKind = uncurryType+#else+uncurryKind = go []+ where+ go args (ArrowK k1 k2) = go (k1:args) k2+ go args StarK = ([], [], reverse args :|- StarK)+#endif++-- Reconstruct a function type from its type variable binders, context,+-- argument types and return type.+curryType :: [TyVarBndr] -> Cxt -> [Type] -> Type -> Type+curryType tvbs ctxt args res =+ ForallT tvbs ctxt $ foldr (\arg t -> ArrowT `AppT` arg `AppT` t) res args+ -- | Resolve any infix type application in a type using the fixities that -- are currently available. Starting in `template-haskell-2.11` types could -- contain unresolved infix applications.@@ -1241,6 +1463,11 @@ resolveInfixT (InfixT l o r) = conT o `appT` resolveInfixT l `appT` resolveInfixT r resolveInfixT (SigT t k) = SigT <$> resolveInfixT t <*> resolveInfixT k resolveInfixT t@UInfixT{} = resolveInfixT =<< resolveInfixT1 (gatherUInfixT t)+# if MIN_VERSION_template_haskell(2,15,0)+resolveInfixT (f `AppKindT` x) = appKindT (resolveInfixT f) (resolveInfixT x)+resolveInfixT (ImplicitParamT n t)+ = implicitParamT n $ resolveInfixT t+# endif resolveInfixT t = return t gatherUInfixT :: Type -> InfixList@@ -1409,6 +1636,10 @@ in case t of VarT n -> Map.insert n k kSigs _ -> go_ty t `mappend` kSigs+#if MIN_VERSION_template_haskell(2,15,0)+ go_ty (AppKindT t k) = go_ty t `mappend` go_ty k+ go_ty (ImplicitParamT _ t) = go_ty t+#endif go_ty _ = mempty go_pred :: Pred -> Map Name Kind@@ -1551,6 +1782,11 @@ go (UInfixT l c r) = UInfixT (go l) c (go r) go (ParensT t) = ParensT (go t) #endif+#if MIN_VERSION_template_haskell(2,15,0)+ go (AppKindT t k) = AppKindT (go t) (go k)+ go (ImplicitParamT n t)+ = ImplicitParamT n (go t)+#endif go t = t freeVariables t =@@ -1568,6 +1804,11 @@ UInfixT l _ r -> freeVariables l `union` freeVariables r ParensT t' -> freeVariables t' #endif+#if MIN_VERSION_template_haskell(2,15,0)+ AppKindT t k -> freeVariables t `union` freeVariables k+ ImplicitParamT _ t+ -> freeVariables t+#endif _ -> [] instance TypeSubstitution ConstructorInfo where@@ -1719,26 +1960,23 @@ -- GADT type variables of kind *. To work around this, we insert the kinds -- manually on any types without a signature. -giveTypesStarKinds :: DatatypeInfo -> DatatypeInfo-giveTypesStarKinds info =- info { datatypeVars = annotateVars (datatypeVars info) }- where- annotateVars :: [Type] -> [Type]- annotateVars = map $ \t ->- case t of- VarT n -> SigT (VarT n) starK- _ -> t+giveDIVarsStarKinds :: DatatypeInfo -> DatatypeInfo+giveDIVarsStarKinds info =+ info { datatypeVars = map giveTyVarBndrStarKind (datatypeVars info)+ , datatypeInstTypes = map giveTypeStarKind (datatypeInstTypes info) } -giveTyVarBndrsStarKinds :: ConstructorInfo -> ConstructorInfo-giveTyVarBndrsStarKinds info =- info { constructorVars = annotateVars (constructorVars info) }- where- annotateVars :: [TyVarBndr] -> [TyVarBndr]- annotateVars = map $ \tvb ->- case tvb of- PlainTV n -> KindedTV n starK- _ -> tvb+giveCIVarsStarKinds :: ConstructorInfo -> ConstructorInfo+giveCIVarsStarKinds info =+ info { constructorVars = map giveTyVarBndrStarKind (constructorVars info) } +giveTyVarBndrStarKind :: TyVarBndr -> TyVarBndr+giveTyVarBndrStarKind (PlainTV n) = KindedTV n starK+giveTyVarBndrStarKind tvb@KindedTV{} = tvb++giveTypeStarKind :: Type -> Type+giveTypeStarKind t@(VarT n) = SigT t starK+giveTypeStarKind t = t+ -- | Prior to GHC 8.2.1, reify was broken for data instances and newtype -- instances. This code attempts to detect the problem and repair it if -- possible.@@ -1762,7 +2000,7 @@ where used = freeVariables (datatypeCons info)- bound = freeVariables (datatypeVars info)+ bound = map tvName (datatypeVars info) free = used \\ bound substList =@@ -1819,14 +2057,19 @@ -- | Backward compatible version of 'tySynInstD' tySynInstDCompat ::- Name {- ^ type family name -} ->- [TypeQ] {- ^ instance parameters -} ->- TypeQ {- ^ instance result -} ->+ Name {- ^ type family name -} ->+ Maybe [Q TyVarBndr] {- ^ type variable binders -} ->+ [TypeQ] {- ^ instance parameters -} ->+ TypeQ {- ^ instance result -} -> DecQ-#if MIN_VERSION_template_haskell(2,9,0)-tySynInstDCompat n ps r = TySynInstD n <$> (TySynEqn <$> sequence ps <*> r)+#if MIN_VERSION_template_haskell(2,15,0)+tySynInstDCompat n mtvbs ps r = TySynInstD <$> (TySynEqn <$> mapM sequence mtvbs+ <*> foldl' appT (conT n) ps+ <*> r)+#elif MIN_VERSION_template_haskell(2,9,0)+tySynInstDCompat n _ ps r = TySynInstD n <$> (TySynEqn <$> sequence ps <*> r) #else-tySynInstDCompat = tySynInstD+tySynInstDCompat n _ = tySynInstD n #endif -- | Backward compatible version of 'pragLineD'. Returns
test/Harness.hs view
@@ -42,22 +42,27 @@ -- otherwise return a string exlaining the mismatch. equateDI :: DatatypeInfo -> DatatypeInfo -> Either String () equateDI dat1 dat2 =- do check "datatypeName" (nameBase . datatypeName) dat1 dat2- check "datatypeVars len" (length . datatypeVars) dat1 dat2- check "datatypeVariant" datatypeVariant dat1 dat2- check "datatypeCons len" (length . datatypeCons) dat1 dat2+ do check "datatypeName" (nameBase . datatypeName) dat1 dat2+ check "datatypeVars len" (length . datatypeVars) dat1 dat2+ check "datatypeInstTypes len" (length . datatypeInstTypes) dat1 dat2+ check "datatypeVariant" datatypeVariant dat1 dat2+ check "datatypeCons len" (length . datatypeCons) dat1 dat2 - let sub = Map.fromList (zip (freeVariables (datatypeVars dat2))- (map VarT (freeVariables (datatypeVars dat1))))+ let sub = Map.fromList (zip (freeVariables (bndrParams (datatypeVars dat2)))+ (map VarT (freeVariables (bndrParams (datatypeVars dat1))))) + check "datatypeVars" id+ (datatypeVars dat1)+ (substIntoTyVarBndrs sub (datatypeVars dat2))++ check "datatypeInstTypes" id+ (datatypeInstTypes dat1)+ (applySubstitution sub (datatypeInstTypes dat2))+ zipWithM_ (equateCxt "datatypeContext") (datatypeContext dat1) (applySubstitution sub (datatypeContext dat2)) - check "datatypeVars" id- (datatypeVars dat1)- (applySubstitution sub (datatypeVars dat2))- zipWithM_ equateCI (datatypeCons dat1) (datatypeCons dat2) -- Don't bother applying the substitution here, as@@ -75,14 +80,11 @@ do check "constructorName" (nameBase . constructorName) con1 con2 check "constructorVariant" constructorVariantBase con1 con2 - let sub1 = Map.fromList (zip (map tvName (constructorVars con2))- (map VarT (map tvName (constructorVars con1))))- sub2 = Map.fromList (zip (freeVariables (map tvKind (constructorVars con2)))- (map VarT (freeVariables- (map tvKind (constructorVars con1)))))- sub3 = Map.fromList (zip (freeVariables con2)+ let sub1 = Map.fromList (zip (freeVariables (bndrParams (constructorVars con2)))+ (map VarT (freeVariables (bndrParams (constructorVars con1)))))+ sub2 = Map.fromList (zip (freeVariables con2) (map VarT (freeVariables con1)))- sub = Map.unions [sub1, sub2, sub3]+ sub = Map.unions [sub1, sub2] zipWithM_ (equateCxt "constructorContext") (constructorContext con1)@@ -107,20 +109,26 @@ i@InfixConstructor{} -> i RecordConstructor fields -> RecordConstructor $ map (mkName . nameBase) fields - -- Substitutes both type variable names and kinds.- substIntoTyVarBndrs :: Map Name Type -> [TyVarBndr] -> [TyVarBndr]- substIntoTyVarBndrs subst = map go- where- go (PlainTV n) = PlainTV $ substName subst n- go (KindedTV n k) = KindedTV (substName subst n)- (applySubstitution subst k)+-- Substitutes both type variable names and kinds.+substIntoTyVarBndrs :: Map Name Type -> [TyVarBndr] -> [TyVarBndr]+substIntoTyVarBndrs subst = map go+ where+ go (PlainTV n) = PlainTV $ substName subst n+ go (KindedTV n k) = KindedTV (substName subst n)+ (applySubstitution subst k) - substName :: Map Name Type -> Name -> Name- substName subst n = fromMaybe n $ do- nty <- Map.lookup n subst- case nty of- VarT n' -> Just n'- _ -> Nothing+ substName :: Map Name Type -> Name -> Name+ substName subst n = fromMaybe n $ do+ nty <- Map.lookup n subst+ case nty of+ VarT n' -> Just n'+ _ -> Nothing++bndrParams :: [TyVarBndr] -> [Type]+bndrParams = map $ \bndr ->+ case bndr of+ KindedTV t k -> SigT (VarT t) k+ PlainTV t -> VarT t equateStrictness :: FieldStrictness -> FieldStrictness -> Either String () equateStrictness fs1 fs2 =
test/Main.hs view
@@ -4,6 +4,11 @@ {-# LANGUAGE ConstraintKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 807+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+#endif+ #if MIN_VERSION_template_haskell(2,8,0) {-# Language PolyKinds #-} #endif@@ -55,6 +60,7 @@ recordVanillaTest #if MIN_VERSION_template_haskell(2,6,0) t43Test+ t58Test #endif #if MIN_VERSION_template_haskell(2,7,0) dataFamilyTest@@ -80,11 +86,15 @@ kindSubstTest t59Test t61Test+ t66Test #endif #if __GLASGOW_HASKELL__ >= 800 t37Test polyKindedExTyvarTest #endif+#if __GLASGOW_HASKELL__ >= 807+ resolveTypeSynonymsVKATest+#endif regressionTest44 t63Test t70Test@@ -93,21 +103,24 @@ adt1Test = $(do info <- reifyDatatype ''Adt1 - let vars@[a,b] = map (VarT . mkName) ["a","b"]- [aSig,bSig] = map (\v -> SigT v starK) vars+ let names = map mkName ["a","b"]+ [aTvb,bTvb] = map (\v -> KindedTV v starK) names+ vars@[aVar,bVar] = map (VarT . mkName) ["a","b"]+ [aSig,bSig] = map (\v -> SigT v starK) vars validateDI info DatatypeInfo { datatypeName = ''Adt1 , datatypeContext = []- , datatypeVars = [aSig, bSig]+ , datatypeVars = [aTvb,bTvb]+ , datatypeInstTypes = [aSig, bSig] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'Adtc1 , constructorContext = [] , constructorVars = []- , constructorFields = [AppT (AppT (TupleT 2) a) b]+ , constructorFields = [AppT (AppT (TupleT 2) aVar) bVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo@@ -125,19 +138,21 @@ gadt1Test = $(do info <- reifyDatatype ''Gadt1 - let a = VarT (mkName "a")+ let a = mkName "a"+ aVar = VarT a validateDI info DatatypeInfo { datatypeName = ''Gadt1 , datatypeContext = []- , datatypeVars = [SigT a starK]+ , datatypeVars = [KindedTV a starK]+ , datatypeInstTypes = [SigT aVar starK] , datatypeVariant = Datatype , datatypeCons = [ ConstructorInfo { constructorName = 'Gadtc1 , constructorVars = []- , constructorContext = [equalPred a (ConT ''Int)]+ , constructorContext = [equalPred aVar (ConT ''Int)] , constructorFields = [ConT ''Int] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor }@@ -145,20 +160,20 @@ { constructorName = 'Gadtc2 , constructorVars = [] , constructorContext = []- , constructorFields = [AppT (AppT (TupleT 2) a) a]+ , constructorFields = [AppT (AppT (TupleT 2) aVar) aVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } , ConstructorInfo { constructorName = '(:**:) , constructorVars = []- , constructorContext = [equalPred a (TupleT 0)]+ , constructorContext = [equalPred aVar (TupleT 0)] , constructorFields = [ConT ''Bool, ConT ''Char] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = InfixConstructor } , ConstructorInfo { constructorName = '(:!!:) , constructorVars = []- , constructorContext = [equalPred a (ConT ''Double)]+ , constructorContext = [equalPred aVar (ConT ''Double)] , constructorFields = [ConT ''Char, ConT ''Bool] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor }@@ -170,15 +185,17 @@ gadtrec1Test = $(do info <- reifyDatatype ''Gadtrec1 - let con = gadtRecVanillaCI+ let a = mkName "a"+ con = gadtRecVanillaCI validateDI info DatatypeInfo- { datatypeName = ''Gadtrec1- , datatypeContext = []- , datatypeVars = [SigT (VarT (mkName "a")) starK]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''Gadtrec1+ , datatypeContext = []+ , datatypeVars = [KindedTV a starK]+ , datatypeInstTypes = [SigT (VarT a) starK]+ , datatypeVariant = Datatype+ , datatypeCons = [ con, con { constructorName = 'Gadtrecc2 } ] } )@@ -187,23 +204,30 @@ equalTest = $(do info <- reifyDatatype ''Equal - let vars@[a,b,c] = map (VarT . mkName) ["a","b","c"]- [aSig,bSig,cSig] = map (\v -> SigT v starK) vars+ let names = map mkName ["a","b","c"]+ [aTvb,bTvb,cTvb] = map (\v -> KindedTV v starK) names+ vars@[aVar,bVar,cVar] = map VarT names+ [aSig,bSig,cSig] = map (\v -> SigT v starK) vars validateDI info DatatypeInfo- { datatypeName = ''Equal- , datatypeContext = []- , datatypeVars = [aSig, bSig, cSig]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''Equal+ , datatypeContext = []+ , datatypeVars = [aTvb, bTvb, cTvb]+ , datatypeInstTypes = [aSig, bSig, cSig]+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'Equalc , constructorVars = [] , constructorContext =- [equalPred a c, equalPred b c, classPred ''Read [c], classPred ''Show [c] ]+ [ equalPred aVar cVar+ , equalPred bVar cVar+ , classPred ''Read [cVar]+ , classPred ''Show [cVar]+ ] , constructorFields =- [ListT `AppT` c, ConT ''Maybe `AppT` c]+ [ListT `AppT` cVar, ConT ''Maybe `AppT` cVar] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = NormalConstructor }@@ -219,11 +243,12 @@ validateDI info DatatypeInfo- { datatypeName = ''Showable- , datatypeContext = []- , datatypeVars = []- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''Showable+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'Showable , constructorVars = [KindedTV a starK]@@ -240,11 +265,12 @@ $(do info <- reifyDatatype ''R validateDI info DatatypeInfo- { datatypeName = ''R- , datatypeContext = []- , datatypeVars = []- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''R+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'R1 , constructorVars = []@@ -259,10 +285,13 @@ gadt2Test :: IO () gadt2Test = $(do info <- reifyDatatype ''Gadt2- let vars@[a,b] = map (VarT . mkName) ["a","b"]- [aSig,bSig] = map (\v -> SigT v starK) vars- x = mkName "x"- con = ConstructorInfo+ let names = map mkName ["a","b"]+ [aTvb,bTvb] = map (\v -> KindedTV v starK) names+ vars@[aVar,bVar] = map VarT names+ [aSig,bSig] = map (\v -> SigT v starK) vars+ x = mkName "x"++ con = ConstructorInfo { constructorName = undefined , constructorVars = [] , constructorContext = []@@ -271,20 +300,21 @@ , constructorVariant = NormalConstructor } validateDI info DatatypeInfo- { datatypeName = ''Gadt2- , datatypeContext = []- , datatypeVars = [aSig, bSig]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''Gadt2+ , datatypeContext = []+ , datatypeVars = [aTvb, bTvb]+ , datatypeInstTypes = [aSig, bSig]+ , datatypeVariant = Datatype+ , datatypeCons = [ con { constructorName = 'Gadt2c1- , constructorContext = [equalPred b (AppT ListT a)] }+ , constructorContext = [equalPred bVar (AppT ListT aVar)] } , con { constructorName = 'Gadt2c2- , constructorContext = [equalPred a (AppT ListT b)] }+ , constructorContext = [equalPred aVar (AppT ListT bVar)] } , con { constructorName = 'Gadt2c3 , constructorVars = [KindedTV x starK] , constructorContext =- [equalPred a (AppT ListT (VarT x))- ,equalPred b (AppT ListT (VarT x))] } ]+ [equalPred aVar (AppT ListT (VarT x))+ ,equalPred bVar (AppT ListT (VarT x))] } ] } ) @@ -294,11 +324,12 @@ let g = mkName "g" validateDI info DatatypeInfo- { datatypeName = ''VoidStoS- , datatypeContext = []- , datatypeVars = [SigT (VarT g) (arrowKCompat starK starK)]- , datatypeVariant = Datatype- , datatypeCons = []+ { datatypeName = ''VoidStoS+ , datatypeContext = []+ , datatypeVars = [KindedTV g (arrowKCompat starK starK)]+ , datatypeInstTypes = [SigT (VarT g) (arrowKCompat starK starK)]+ , datatypeVariant = Datatype+ , datatypeCons = [] } ) @@ -307,11 +338,12 @@ $(do info <- reifyDatatype ''StrictDemo validateDI info DatatypeInfo- { datatypeName = ''StrictDemo- , datatypeContext = []- , datatypeVars = []- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = ''StrictDemo+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'StrictDemo , constructorVars = []@@ -337,11 +369,12 @@ infoPlain <- normalizeDec decPlain validateDI infoPlain DatatypeInfo- { datatypeName = mkName "T43Plain"- , datatypeContext = []- , datatypeVars = []- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeName = mkName "T43Plain"+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Plain" , constructorVars = []@@ -355,11 +388,12 @@ infoFam <- normalizeDec decFam validateDI infoFam DatatypeInfo- { datatypeName = mkName "T43Fam"- , datatypeContext = []- , datatypeVars = []- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = mkName "T43Fam"+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = DataInstance+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Fam" , constructorVars = []@@ -369,6 +403,30 @@ , constructorVariant = NormalConstructor } ] } )++t58Test :: IO ()+t58Test =+ $(do [dec] <- [d| data Foo where+ MkFoo :: a -> Foo |]+ info <- normalizeDec dec+ let a = mkName "a"+ validateDI info+ DatatypeInfo+ { datatypeName = mkName "Foo"+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = []+ , datatypeVariant = Datatype+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "MkFoo"+ , constructorVars = [KindedTV a starK]+ , constructorContext = []+ , constructorFields = [VarT a]+ , constructorStrictness = [notStrictAnnot]+ , constructorVariant = NormalConstructor } ]+ }+ ) #endif #if MIN_VERSION_template_haskell(2,7,0)@@ -378,11 +436,12 @@ let a = mkName "a" validateDI info DatatypeInfo- { datatypeName = ''DF- , datatypeContext = []- , datatypeVars = [AppT (ConT ''Maybe) (VarT a)]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''DF+ , datatypeContext = []+ , datatypeVars = [KindedTV a starK]+ , datatypeInstTypes = [AppT (ConT ''Maybe) (VarT a)]+ , datatypeVariant = DataInstance+ , datatypeCons = [ ConstructorInfo { constructorName = 'DFMaybe , constructorVars = []@@ -396,19 +455,21 @@ ghc78bugTest :: IO () ghc78bugTest = $(do info <- reifyDatatype 'DF1- let c = VarT (mkName "c")+ let c = mkName "c"+ cVar = VarT c validateDI info DatatypeInfo- { datatypeName = ''DF1- , datatypeContext = []- , datatypeVars = [SigT c starK]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''DF1+ , datatypeContext = []+ , datatypeVars = [KindedTV c starK]+ , datatypeInstTypes = [SigT cVar starK]+ , datatypeVariant = DataInstance+ , datatypeCons = [ ConstructorInfo { constructorName = 'DF1 , constructorVars = [] , constructorContext = []- , constructorFields = [c]+ , constructorFields = [cVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] }@@ -418,19 +479,21 @@ quotedTest = $(do [dec] <- [d| data instance Quoted a = MkQuoted a |] info <- normalizeDec dec- let a = VarT (mkName "a")+ let a = mkName "a"+ aVar = VarT a validateDI info DatatypeInfo- { datatypeName = mkName "Quoted"- , datatypeContext = []- , datatypeVars = [SigT a starK]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = mkName "Quoted"+ , datatypeContext = []+ , datatypeVars = [KindedTV a starK]+ , datatypeInstTypes = [SigT aVar starK]+ , datatypeVariant = DataInstance+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkQuoted" , constructorVars = [] , constructorContext = []- , constructorFields = [a]+ , constructorFields = [aVar] , constructorStrictness = [notStrictAnnot] , constructorVariant = NormalConstructor } ] }@@ -440,13 +503,19 @@ polyTest = $(do info <- reifyDatatype 'MkPoly let [a,k] = map mkName ["a","k"]+ kVar = varKCompat k validateDI info DatatypeInfo- { datatypeName = ''Poly- , datatypeContext = []- , datatypeVars = [SigT (VarT a) (varKCompat k)]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''Poly+ , datatypeContext = []+ , datatypeVars = [+#if __GLASGOW_HASKELL__ >= 800+ KindedTV k starK,+#endif+ KindedTV a kVar ]+ , datatypeInstTypes = [SigT (VarT a) kVar]+ , datatypeVariant = DataInstance+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkPoly , constructorVars = []@@ -460,16 +529,18 @@ gadtFamTest :: IO () gadtFamTest = $(do info <- reifyDatatype 'MkGadtFam1- let names@[c,d,e,q] = map mkName ["c","d","e","q"]- [cTy,dTy,eTy,qTy] = map VarT names- [cSig,dSig] = map (\v -> SigT v starK) [cTy,dTy]+ let names@[c,d,e,q] = map mkName ["c","d","e","q"]+ [cTvb,dTvb,eTvb,qTvb] = map (\v -> KindedTV v starK) names+ [cTy,dTy,eTy,qTy] = map VarT names+ [cSig,dSig] = map (\v -> SigT v starK) [cTy,dTy] validateDI info DatatypeInfo- { datatypeName = ''GadtFam- , datatypeContext = []- , datatypeVars = [cSig,dSig]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''GadtFam+ , datatypeContext = []+ , datatypeVars = [cTvb,dTvb]+ , datatypeInstTypes = [cSig,dSig]+ , datatypeVariant = DataInstance+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkGadtFam1 , constructorVars = []@@ -522,11 +593,12 @@ info <- normalizeDec dec validateDI info DatatypeInfo- { datatypeName = ''FamLocalDec1- , datatypeContext = []- , datatypeVars = [ConT ''Int]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''FamLocalDec1+ , datatypeContext = []+ , datatypeVars = []+ , datatypeInstTypes = [ConT ''Int]+ , datatypeVariant = DataInstance+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec1Int" , constructorVars = []@@ -541,20 +613,23 @@ famLocalDecTest2 = $(do [dec] <- [d| data instance FamLocalDec2 Int (a, b) a = FamLocalDec2Int { fm0 :: (b, a), fm1 :: Int } |] info <- normalizeDec dec- let tys@[a,b] = map (VarT . mkName) ["a", "b"]- [aSig,bSig] = map (\v -> SigT v starK) tys+ let names = map mkName ["a", "b"]+ [aTvb,bTvb] = map (\v -> KindedTV v starK) names+ vars@[aVar,bVar] = map (VarT . mkName) ["a", "b"]+ [aSig,bSig] = map (\v -> SigT v starK) vars validateDI info DatatypeInfo- { datatypeName = ''FamLocalDec2- , datatypeContext = []- , datatypeVars = [ConT ''Int, TupleT 2 `AppT` a `AppT` b, aSig]- , datatypeVariant = DataInstance- , datatypeCons =+ { datatypeName = ''FamLocalDec2+ , datatypeContext = []+ , datatypeVars = [aTvb,bTvb]+ , datatypeInstTypes = [ConT ''Int, TupleT 2 `AppT` aVar `AppT` bVar, aSig]+ , datatypeVariant = DataInstance+ , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec2Int" , constructorVars = [] , constructorContext = []- , constructorFields = [TupleT 2 `AppT` b `AppT` a, ConT ''Int]+ , constructorFields = [TupleT 2 `AppT` bVar `AppT` aVar, ConT ''Int] , constructorStrictness = [notStrictAnnot, notStrictAnnot] , constructorVariant = RecordConstructor [mkName "fm0", mkName "fm1"] }] }@@ -573,7 +648,6 @@ unless (null ctxt) (fail "regression test for ticket #46 failed") _ -> fail "T46 should have exactly one constructor" [| return () |])- #endif fixityLookupTest :: IO ()@@ -598,13 +672,15 @@ reifyDatatypeWithConNameTest :: IO () reifyDatatypeWithConNameTest = $(do info <- reifyDatatype 'Just+ let a = mkName "a" validateDI info DatatypeInfo- { datatypeContext = []- , datatypeName = ''Maybe- , datatypeVars = [SigT (VarT (mkName "a")) starK]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''Maybe+ , datatypeVars = [KindedTV a starK]+ , datatypeInstTypes = [SigT (VarT a) starK]+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'Nothing , constructorVars = []@@ -627,20 +703,26 @@ importedEqualityTest :: IO () importedEqualityTest = $(do info <- reifyDatatype ''(:~:)- let [a,b] = map (VarT . mkName) ["a","b"]- k = mkName "k"- kKind = varKCompat k+ let names@[a,b] = map mkName ["a","b"]+ [aVar,bVar] = map VarT names+ k = mkName "k"+ kKind = varKCompat k validateDI info DatatypeInfo- { datatypeContext = []- , datatypeName = ''(:~:)- , datatypeVars = [SigT a kKind, SigT b kKind]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''(:~:)+ , datatypeVars = [+#if __GLASGOW_HASKELL__ >= 800+ KindedTV k starK,+#endif+ KindedTV a kKind, KindedTV b kKind]+ , datatypeInstTypes = [SigT aVar kKind, SigT bVar kKind]+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'Refl , constructorVars = []- , constructorContext = [equalPred a b]+ , constructorContext = [equalPred aVar bVar] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ]@@ -717,24 +799,57 @@ (ConT ''Int) #endif [| return () |])++t66Test :: IO ()+t66Test =+ $(do [dec] <- [d| data Foo a b :: (* -> *) -> * -> * where+ MkFoo :: a -> b -> f x -> Foo a b f x |]+ info <- normalizeDec dec+ let [a,b,f,x] = map mkName ["a","b","f","x"]+ fKind = arrowKCompat starK starK+ validateDI info+ DatatypeInfo+ { datatypeName = mkName "Foo"+ , datatypeContext = []+ , datatypeVars = [ KindedTV a starK ,KindedTV b starK+ , KindedTV f fKind, KindedTV x starK ]+ , datatypeInstTypes = [ SigT (VarT a) starK, SigT (VarT b) starK+ , SigT (VarT f) fKind, SigT (VarT x) starK ]+ , datatypeVariant = Datatype+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "MkFoo"+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [VarT a, VarT b, VarT f `AppT` VarT x]+ , constructorStrictness = [notStrictAnnot, notStrictAnnot, notStrictAnnot]+ , constructorVariant = NormalConstructor } ]+ }+ ) #endif #if __GLASGOW_HASKELL__ >= 800 t37Test :: IO () t37Test = $(do infoA <- reifyDatatype ''T37a- let [k,a] = map (VarT . mkName) ["k","a"]+ let names@[k,a] = map mkName ["k","a"]+ [kVar,aVar] = map VarT names+ kSig = SigT kVar starK+ aSig = SigT aVar kVar+ kTvb = KindedTV k starK+ aTvb = KindedTV a kVar validateDI infoA DatatypeInfo- { datatypeContext = []- , datatypeName = ''T37a- , datatypeVars = [SigT k starK, SigT a k]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''T37a+ , datatypeVars = [kTvb, aTvb]+ , datatypeInstTypes = [kSig, aSig]+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37a , constructorVars = []- , constructorContext = [equalPred k (ConT ''Bool)]+ , constructorContext = [equalPred kVar (ConT ''Bool)] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ]@@ -743,15 +858,16 @@ infoB <- reifyDatatype ''T37b validateDI infoB DatatypeInfo- { datatypeContext = []- , datatypeName = ''T37b- , datatypeVars = [SigT a k]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''T37b+ , datatypeVars = [kTvb, aTvb]+ , datatypeInstTypes = [aSig]+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37b , constructorVars = []- , constructorContext = [equalPred k (ConT ''Bool)]+ , constructorContext = [equalPred kVar (ConT ''Bool)] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ]@@ -760,15 +876,16 @@ infoC <- reifyDatatype ''T37c validateDI infoC DatatypeInfo- { datatypeContext = []- , datatypeName = ''T37c- , datatypeVars = [SigT a k]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''T37c+ , datatypeVars = [kTvb, aTvb]+ , datatypeInstTypes = [aSig]+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37c , constructorVars = []- , constructorContext = [equalPred a (ConT ''Bool)]+ , constructorContext = [equalPred aVar (ConT ''Bool)] , constructorFields = [] , constructorStrictness = [] , constructorVariant = NormalConstructor } ]@@ -779,16 +896,18 @@ polyKindedExTyvarTest = $(do info <- reifyDatatype ''T48 let [a,x] = map mkName ["a","x"]+ aVar = VarT a validateDI info DatatypeInfo- { datatypeContext = []- , datatypeName = ''T48- , datatypeVars = [SigT (VarT a) starK]- , datatypeVariant = Datatype- , datatypeCons =+ { datatypeContext = []+ , datatypeName = ''T48+ , datatypeVars = [KindedTV a starK]+ , datatypeInstTypes = [SigT aVar starK]+ , datatypeVariant = Datatype+ , datatypeCons = [ ConstructorInfo { constructorName = 'MkT48- , constructorVars = [KindedTV x (VarT a)]+ , constructorVars = [KindedTV x aVar] , constructorContext = [] , constructorFields = [ConT ''Prox `AppT` VarT x] , constructorStrictness = [notStrictAnnot]@@ -799,7 +918,7 @@ -- unfortunately does not check if the uses of `a` in datatypeVars and -- constructorVars are the same. We perform this check explicitly here. case info of- DatatypeInfo { datatypeVars = [SigT (VarT a1) starK]+ DatatypeInfo { datatypeVars = [KindedTV a1 starK] , datatypeCons = [ ConstructorInfo { constructorVars = [KindedTV _ (VarT a2)] } ] } ->@@ -808,6 +927,17 @@ ++ show [a1, a2] [| return () |] )+#endif++#if __GLASGOW_HASKELL__ >= 807+resolveTypeSynonymsVKATest :: IO ()+resolveTypeSynonymsVKATest =+ $(do t <- [t| T37b @Bool True |]+ t' <- resolveTypeSynonyms t+ unless (t == t') $+ fail $ "Type synonym expansion breaks with visible kind application: "+ ++ show [t, t']+ [| return () |]) #endif regressionTest44 :: IO ()
th-abstraction.cabal view
@@ -1,5 +1,5 @@ name: th-abstraction-version: 0.2.11.0+version: 0.3.0.0 synopsis: Nicer interface for reified information about data types description: This package normalizes variations in the interface for inspecting datatype information via Template Haskell@@ -17,7 +17,7 @@ build-type: Simple extra-source-files: ChangeLog.md README.md cabal-version: >=1.10-tested-with: GHC==8.6.3, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4+tested-with: GHC==8.8.1, GHC==8.6.4, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 source-repository head type: git@@ -28,7 +28,7 @@ other-modules: Language.Haskell.TH.Datatype.Internal build-depends: base >=4.3 && <5, ghc-prim,- template-haskell >=2.5 && <2.15,+ template-haskell >=2.5 && <2.16, containers >=0.4 && <0.7 hs-source-dirs: src default-language: Haskell2010