th-abstraction 0.6.0.0 → 0.7.0.0
raw patch · 6 files changed
+828/−67 lines, 6 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Language.Haskell.TH.Datatype: [datatypeReturnKind] :: DatatypeInfo -> Kind
- Language.Haskell.TH.Datatype: DatatypeInfo :: Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> DatatypeVariant -> [ConstructorInfo] -> DatatypeInfo
+ Language.Haskell.TH.Datatype: DatatypeInfo :: Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> DatatypeVariant -> Kind -> [ConstructorInfo] -> DatatypeInfo
- Language.Haskell.TH.Datatype: normalizeCon :: Name -> [TyVarBndrUnit] -> [Type] -> DatatypeVariant -> Con -> Q [ConstructorInfo]
+ Language.Haskell.TH.Datatype: normalizeCon :: Name -> [TyVarBndrUnit] -> [Type] -> Kind -> DatatypeVariant -> Con -> Q [ConstructorInfo]
- Language.Haskell.TH.Datatype.TyVarBndr: data Specificity
+ Language.Haskell.TH.Datatype.TyVarBndr: data () => Specificity
Files
- ChangeLog.md +15/−0
- src/Language/Haskell/TH/Datatype.hs +515/−53
- test/Harness.hs +6/−2
- test/Main.hs +266/−8
- test/Types.hs +22/−0
- th-abstraction.cabal +4/−4
ChangeLog.md view
@@ -1,5 +1,20 @@ # Revision history for th-abstraction +## 0.7.0.0 -- 2024.03.17+* `DatatypeInfo` now has an additional `datatypeReturnKind` field. Most of the+ time, this will be `StarT`, but this can also be more exotic kinds such as+ `ConT ''UnliftedType` if dealing with primitive types, `UnliftedDatatypes`,+ or `UnliftedNewtypes`.+* `reifyDatatype` and related functions now support primitive types such as+ `Int#`. These will be reified as `DatatypeInfo`s with no `ConstructorInfo`s+ and with `Datatype` as the `datatypeVariant`.+* `normalizeCon` now takes a `Kind` argument representing the return kind of+ the parent data type. (This is sometimes necessary to determine which type+ variables in the data constructor are universal or existential, depending+ on if the variables appear in the return kind.)+* Fix a couple of bugs in which `normalizeDec` would return incorrect results+ for GADTs that use `forall`s in their return kind.+ ## 0.6.0.0 -- 2023.07.31 * Support building with `template-haskell-2.21.0.0` (GHC 9.8). * Adapt to `TyVarBndr`s for type-level declarations changing their type from
src/Language/Haskell/TH/Datatype.hs view
@@ -1,4 +1,4 @@-{-# Language CPP, DeriveDataTypeable #-}+{-# Language CPP, DeriveDataTypeable, ScopedTypeVariables, TupleSections #-} #if MIN_VERSION_base(4,4,0) #define HAS_GENERICS@@ -31,6 +31,7 @@ , 'datatypeVars' = [ 'KindedTV' a_3530822107858468866 () 'StarT' ] , 'datatypeInstTypes' = [ 'SigT' ('VarT' a_3530822107858468866) 'StarT' ] , 'datatypeVariant' = 'Datatype'+ , 'datatypeReturnKind' = 'StarT' , 'datatypeCons' = [ 'ConstructorInfo' { 'constructorName' = GHC.Base.Nothing@@ -202,6 +203,10 @@ , datatypeVars :: [TyVarBndrUnit] -- ^ Type parameters , datatypeInstTypes :: [Type] -- ^ Argument types , datatypeVariant :: DatatypeVariant -- ^ Extra information+ , datatypeReturnKind:: Kind -- ^ Return 'Kind' of the type.+ --+ -- If normalization is unable to determine the return kind,+ -- then this is conservatively set to @StarT@. , datatypeCons :: [ConstructorInfo] -- ^ Normalize constructor information } deriving (Show, Eq, Typeable, Data@@ -212,7 +217,7 @@ -- | Possible variants of data type declarations. data DatatypeVariant- = Datatype -- ^ Type declared with @data@.+ = Datatype -- ^ Type declared with @data@ or a primitive datatype. | Newtype -- ^ Type declared with @newtype@. -- -- A 'DatatypeInfo' that uses 'Newtype' will uphold the@@ -377,6 +382,9 @@ -- Trying to categorize which constraints need homogeneous or heterogeneous -- equality is tricky, so we leave that task to users of this library. --+-- Primitive types (other than unboxed sums and tuples) will have+-- no @datatypeCons@ in their normalization.+-- -- This function will apply various bug-fixes to the output of the underlying -- @template-haskell@ library in order to provide a view of datatypes in -- as uniform a way as possible.@@ -437,7 +445,21 @@ normalizeInfo' :: String -> IsReifiedDec -> Info -> Q DatatypeInfo normalizeInfo' entry reifiedDec i = case i of- PrimTyConI{} -> bad "Primitive type not supported"+ (PrimTyConI name arity unlifted) -> do+#if MIN_VERSION_template_haskell(2,16,0)+ -- We provide a minimal @DataD@ because, since TH 2.16,+ -- we can rely on the call to @reifyType@ in+ -- @normalizeDecFor@ to fill in the missing details.+ normalizeDecFor reifiedDec $ DataD [] name [] Nothing [] []+#else+ -- On older versions, we are very limited in what we can deduce.+ -- All we know is the appropriate amount of type constructors.+ -- Note that this will default all kinds to @Type@, which is all+ -- that is available anyway.+ args <- replicateM arity (newName "x")+ dec <- dataDCompat (return []) name (map plainTV args) [] []+ normalizeDecFor reifiedDec dec+#endif ClassI{} -> bad "Class not supported" #if MIN_VERSION_template_haskell(2,11,0) FamilyI DataFamilyD{} _ ->@@ -733,19 +755,66 @@ | otherwise = return di - -- Given a data type's instance types and kind, compute its free variables.- datatypeFreeVars :: [Type] -> Maybe Kind -> [TyVarBndrUnit]- datatypeFreeVars instTys mbKind =- freeVariablesWellScoped $ instTys +++ -- If a data type lacks an explicit return kind, use `reifyType` to compute+ -- it, as described in step (1) of Note [Tricky result kinds].+ normalizeMbKind :: Name -> [Type] -> Maybe Kind -> Q (Maybe Kind)+ normalizeMbKind _name _instTys mbKind@(Just _) = return mbKind+ normalizeMbKind name instTys Nothing = do+#if MIN_VERSION_template_haskell(2,16,0)+ mbReifiedKind <- return Nothing `recover` fmap Just (reifyType name)+ T.mapM normalizeKind mbReifiedKind+ where+ normalizeKind :: Kind -> Q Kind+ normalizeKind k = do+ k' <- resolveKindSynonyms k+ -- Step (1) in Note [Tricky result kinds]+ -- (Wrinkle: normalizeMbKind argument unification).+ let (args, res) = unravelKindUpTo instTys k'+ -- Step (2) in Note [Tricky result kinds]+ -- (Wrinkle: normalizeMbKind argument unification).+ (instTys', args') =+ unzip $+ mapMaybe+ (\(instTy, arg) ->+ case arg of+ VisFADep tvb -> Just (instTy, bndrParam tvb)+ VisFAAnon k -> (, k) <$> sigTMaybeKind instTy)+ args+ (subst, _) = mergeArguments args' instTys'+ -- Step (3) in Note [Tricky result kinds]+ -- (Wrinkle: normalizeMbKind argument unification).+ pure $ applySubstitution (VarT <$> subst) res+#else+ return Nothing+#endif++ -- Given a data type declaration's binders, as well as the arguments and+ -- result of its explicit return kind, compute the free type variables.+ -- For example, this:+ --+ -- @+ -- data T (a :: j) :: forall k. Maybe k -> Type+ -- @+ --+ -- Would yield:+ --+ -- @+ -- [j, (a :: j), k, (b :: k)]+ -- @+ --+ -- Where @b@ is a fresh name that is generated in 'mkExtraFunArgForalls'.+ datatypeFreeVars :: [TyVarBndr_ flag] -> FunArgs -> Kind -> [TyVarBndrUnit]+ datatypeFreeVars declBndrs kindArgs kindRes =+ freeVariablesWellScoped $ bndrParams declBndrs ++ #if MIN_VERSION_template_haskell(2,8,0)- maybeToList mbKind+ funArgTys kindArgs ++ [kindRes] #else- [] -- No kind variables+ [] -- No kind variables #endif normalizeDataD :: Cxt -> Name -> [TyVarBndrVis] -> Maybe Kind -> [Con] -> DatatypeVariant -> Q DatatypeInfo- normalizeDataD context name tyvars mbKind cons variant =+ normalizeDataD context name tyvars mbKind cons variant = do -- NB: use `filter isRequiredTvb tyvars` here. It is possible for some of -- the `tyvars` to be `BndrInvis` if the data type is quoted, e.g., --@@ -753,9 +822,9 @@ -- -- th-abstraction adopts the convention that all binders in the -- 'datatypeInstTypes' are required, so we want to filter out the `@k`.- let tys = bndrParams $ filter isRequiredTvb tyvars in- normalize' context name (datatypeFreeVars (bndrParams tyvars) mbKind)- tys mbKind cons variant+ let tys = bndrParams $ filter isRequiredTvb tyvars+ mbKind' <- normalizeMbKind name tys mbKind+ normalize' context name tyvars tys mbKind' cons variant normalizeDataInstDPostTH2'15 :: String -> Cxt -> Maybe [TyVarBndrUnit] -> Type -> Maybe Kind@@ -763,29 +832,117 @@ normalizeDataInstDPostTH2'15 what context mbTyvars nameInstTys mbKind cons variant = case decomposeType nameInstTys of- ConT name :| instTys ->+ ConT name :| instTys -> do+ mbKind' <- normalizeMbKind name instTys mbKind normalize' context name- (fromMaybe (datatypeFreeVars instTys mbKind) mbTyvars)- instTys mbKind cons variant+ (fromMaybe (freeVariablesWellScoped instTys) 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+ normalizeDataInstDPreTH2'15 context name instTys mbKind cons variant = do+ mbKind' <- normalizeMbKind name instTys mbKind+ normalize' context name (freeVariablesWellScoped instTys)+ instTys mbKind' cons variant -- The main worker of this function.- normalize' :: Cxt -> Name -> [TyVarBndrUnit] -> [Type] -> Maybe Kind+ normalize' :: Cxt -> Name -> [TyVarBndr_ flag] -> [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+ -- If `mbKind` is *still* Nothing after all of the work done in+ -- normalizeMbKind, then conservatively assume that the return kind is+ -- `Type`. See step (1) of Note [Tricky result kinds].+ let kind = fromMaybe starK mbKind+ kind' <- resolveKindSynonyms kind+ let (kindArgs, kindRes) = unravelKind kind'+ (extra_vis_tvbs, kindArgs') <- mkExtraFunArgForalls kindArgs+ let tvbs' = datatypeFreeVars tvbs kindArgs' kindRes+ instTys' = instTys ++ bndrParams extra_vis_tvbs+ dec <- normalizeDec' isReified context name tvbs' instTys' kindRes cons variant repair13618' $ giveDIVarsStarKinds isReified dec +{-+Note [Tricky result kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example, which uses UnliftedNewtypes:++ type T :: TYPE r+ newtype T where+ MkT :: forall r. Any @(TYPE r) -> T @r++This has one universally quantified type variable `r`, but making+`reifyDatatype ''T` realize this is surprisingly tricky. There root of the+trickiness is the fact that `Language.Haskell.TH.reify ''T` will yield this:++ newtype T where+ MkT :: forall r. (Any :: TYPE r) -> (T :: TYPE r)++In particular, note that:++1. `reify` does not give `T` an explicit return kind of `TYPE r`. This is bad,+ because without this, we cannot conclude that `r` is universally quantified.+2. The reified type of the `MkT` constructor uses explicit kind annotations+ instead of visible kind applications. That is, the return type is+ `T :: TYPE r` instead of `T @r`. This makes it even trickier to figure out+ that `r` is universally quantified, as `r` does not appear directly+ underneath an application of `T`.++We resolve each of these issues as follows:++1. In `normalizeDecFor.normalizeMbKind`, we attempt to use `reifyType` to look+ up the return kind of the data type. In the `T` example above, this suffices+ to conclude that `T :: TYPE r`. `reifyType` won't always work (e.g., when+ using `normalizeDec` on a data type without an explicit return kind), so for+ those situations, we conservatively assume that the data type has return kind+ `Type`.++ The implementation of `normalizeMbKind` is somewhat involved. See+ "Wrinkle: normalizeMbKind argument unification" below for more details.+2. After determining the result kind `K1`, we pass `K1` through to+ `normalizeGadtC`. In that function, we check if the return type of the data+ constructor is of the form `Ty :: K2`, and if so, we attempt to unify `K1`+ and `K2` by passing through to `mergeArguments`. In the example above, this+ lets us conclude that the `r` in the data type return kind is the same `r`+ as in the data constructor.++===================================================+== Wrinkle: normalizeMbKind argument unification ==+===================================================++Here is a slightly more involved example:++ type T2 :: TYPE r1 -> TYPE r1+ newtype T2 (a :: TYPE r2) = MkT2 a++Here, we must use `reifyType` in `normalizeMbKind` to determine that the return+kind is `TYPE r1`. But we must be careful here: `r1` is actually the same type+variable as `r2`! We don't want to accidentally end up quantifying over the two+variables separately in `datatypeInstVars`, since they're really one and the+same.++We accomplish this by doing the following:++1. After calling `reifyKind` in `normalizeMbKind`, split the result kind into+ as many arguments as there are visible binders in the data type declaration.+ In the `T2` example above, there is exactly one visible binder in+ `newtype T2 a`, so we split the kind `TYPE r1 -> TYPE r1` by one argument to+ get ([TYPE r1], TYPE r1). See `unravelKindUpTo` for how this splitting logic+ is implemented.+2. We then unify the argument kinds resuling from the splitting in the previous+ step with the corresponding kinds from the data type declaration. In the+ example above, the split argument kind is `TYPE r1`, and the binder in the+ declaration has kind `TYPE r2`, so we unify `TYPE r1` with `TYPE r2` using+ `mergeArgumentKinds` to get a substitution [r1 :-> r2].+3. We then apply the substitution from the previous step to the rest of the+ kind. In the example above, that means we apply the [r1 :-> r2] substitution+ to `TYPE r1` to obtain `TYPE r2`.++The payoff is that everything consistently refers to `r2`, rather than the mix+of `r1` and `r2` as before.+-}+ -- | 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: --@@ -803,10 +960,77 @@ mkExtraKindBinders :: Kind -> Q [TyVarBndrUnit] mkExtraKindBinders kind = do kind' <- resolveKindSynonyms kind- let (_, _, args :|- _) = uncurryKind kind'- names <- replicateM (length args) (newName "x")- return $ zipWith kindedTV names args+ let (args, _) = unravelKind kind'+ (extra_kvbs, _) <- mkExtraFunArgForalls args+ return extra_kvbs +-- | Take the supplied function kind arguments ('FunArgs') and do two things:+--+-- 1. For each 'FAAnon' with kind @k@, generate a fresh name @a@ and return+-- the 'TyVarBndr' @a :: k@. Also return each visible @forall@ in an+-- 'FAForalls' as a 'TyVarBndr'. (This is what the list of 'TyVarBndrUnit's+-- in the return type consists of.)+--+-- 2. Return a new 'FunArgs' value where each 'FAAnon' has been replaced with+-- @'FAForalls' ('ForallVis' [a :: k])@, where @a :: k@ the corresponding+-- 'TyVarBndr' computed in step (1).+--+-- As an example, consider this function kind:+--+-- @+-- forall k. k -> Type -> Type+-- @+--+-- After splitting this kind into its 'FunArgs':+--+-- @+-- ['FAForalls' ('ForallInvis' [k]), 'FAAnon' k, 'FAAnon' Type]+-- @+--+-- Calling 'mkExtraFunArgForalls' on this 'FunArgs' value would return:+--+-- @+-- ( [a :: k, b :: Type]+-- , [ 'FAForalls' ('ForallInvis' [k])+-- , 'FAForalls' ('ForallVis' [a :: k])+-- , 'FAForalls' ('ForallVis' [b :: Type])+-- ]+-- )+-- @+--+-- Where @a@ and @b@ are fresh.+--+-- This function is used in two places:+--+-- 1. As the workhorse for 'mkExtraKindBinders'.+--+-- 2. In 'normalizeDecFor', as part of computing the 'datatypeInstVars' and as+-- part of eta expanding the explicit return kind.+mkExtraFunArgForalls :: FunArgs -> Q ([TyVarBndrUnit], FunArgs)+mkExtraFunArgForalls FANil =+ return ([], FANil)+mkExtraFunArgForalls (FAForalls tele args) = do+ (extra_vis_tvbs', args') <- mkExtraFunArgForalls args+ case tele of+ ForallVis tvbs ->+ return ( tvbs ++ extra_vis_tvbs'+ , FAForalls (ForallVis tvbs) args'+ )+ ForallInvis tvbs ->+ return ( extra_vis_tvbs'+ , FAForalls (ForallInvis tvbs) args'+ )+mkExtraFunArgForalls (FACxt ctxt args) = do+ (extra_vis_tvbs', args') <- mkExtraFunArgForalls args+ return (extra_vis_tvbs', FACxt ctxt args')+mkExtraFunArgForalls (FAAnon anon args) = do+ name <- newName "x"+ let tvb = kindedTV name anon+ (extra_vis_tvbs', args') <- mkExtraFunArgForalls args+ return ( tvb : extra_vis_tvbs'+ , FAForalls (ForallVis [tvb]) args'+ )+ -- | Is a declaration for a @data instance@ or @newtype instance@? isFamInstVariant :: DatatypeVariant -> Bool isFamInstVariant dv =@@ -818,8 +1042,11 @@ TypeData -> False bndrParams :: [TyVarBndr_ flag] -> [Type]-bndrParams = map $ elimTV VarT (\n k -> SigT (VarT n) k)+bndrParams = map bndrParam +bndrParam :: TyVarBndr_ flag -> Type+bndrParam = elimTV VarT (\n k -> SigT (VarT n) k)+ -- | Returns 'True' if the flag of the supplied 'TyVarBndrVis' is 'BndrReq'. isRequiredTvb :: TyVarBndrVis -> Bool #if __GLASGOW_HASKELL__ >= 708@@ -833,6 +1060,11 @@ stripSigT (SigT t _) = t stripSigT t = t +-- | If the supplied 'Type' is a @'SigT' _ k@, return @'Just' k@. Otherwise,+-- return 'Nothing'.+sigTMaybeKind :: Type -> Maybe Kind+sigTMaybeKind (SigT _ k) = Just k+sigTMaybeKind _ = Nothing normalizeDec' :: IsReifiedDec {- ^ Is this a reified 'Dec'? -} ->@@ -840,17 +1072,19 @@ Name {- ^ Type constructor -} -> [TyVarBndrUnit] {- ^ Type parameters -} -> [Type] {- ^ Argument types -} ->+ Kind {- ^ Result kind -} -> [Con] {- ^ Constructors -} -> DatatypeVariant {- ^ Extra information -} -> Q DatatypeInfo-normalizeDec' reifiedDec context name params instTys cons variant =- do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params instTys variant) cons+normalizeDec' reifiedDec context name params instTys resKind cons variant =+ do cons' <- concat <$> mapM (normalizeConFor reifiedDec name params instTys resKind variant) cons return DatatypeInfo { datatypeContext = context , datatypeName = name , datatypeVars = params , datatypeInstTypes = instTys , datatypeCons = cons'+ , datatypeReturnKind = resKind , datatypeVariant = variant } @@ -862,6 +1096,7 @@ Name {- ^ Type constructor -} -> [TyVarBndrUnit] {- ^ Type parameters -} -> [Type] {- ^ Argument types -} ->+ Kind {- ^ Result kind -} -> DatatypeVariant {- ^ Extra information -} -> Con {- ^ Constructor -} -> Q [ConstructorInfo]@@ -872,10 +1107,11 @@ Name {- ^ Type constructor -} -> [TyVarBndrUnit] {- ^ Type parameters -} -> [Type] {- ^ Argument types -} ->+ Kind {- ^ Result kind -} -> DatatypeVariant {- ^ Extra information -} -> Con {- ^ Constructor -} -> Q [ConstructorInfo]-normalizeConFor reifiedDec typename params instTys variant =+normalizeConFor reifiedDec typename params instTys resKind variant = fmap (map (giveCIVarsStarKinds reifiedDec)) . dispatch where -- A GADT constructor is declared infix when:@@ -963,7 +1199,7 @@ gadtCase ns innerType (takeFieldTypes xs) stricts (const $ return $ RecordConstructor fns) where- gadtCase = normalizeGadtC typename params instTys tyvars context+ gadtCase = normalizeGadtC typename params instTys resKind tyvars context #endif #if MIN_VERSION_template_haskell(2,8,0) && (!MIN_VERSION_template_haskell(2,10,0)) dataFamCompatCase :: Con -> Q [ConstructorInfo]@@ -1003,7 +1239,7 @@ -- 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]+ normalizeGadtC typename params instTys resKind tyvars context [n] returnTy' argTys stricts (const $ return variant) _ -> fail $ unlines [ "normalizeCon: Cannot reify constructor " ++ nameBase n@@ -1086,6 +1322,7 @@ Name {- ^ Type constructor -} -> [TyVarBndrUnit] {- ^ Type parameters -} -> [Type] {- ^ Argument types -} ->+ Kind {- ^ Result kind -} -> [TyVarBndrUnit] {- ^ Constructor parameters -} -> Cxt {- ^ Constructor context -} -> [Name] {- ^ Constructor names -} ->@@ -1096,7 +1333,7 @@ {- ^ Determine a constructor variant from its 'Name' -} -> Q [ConstructorInfo]-normalizeGadtC typename params instTys tyvars context names innerType+normalizeGadtC typename params instTys resKind tyvars context names innerType fields stricts getVariant = do -- It's possible that the constructor has implicitly quantified type -- variables, such as in the following example (from #58):@@ -1132,13 +1369,34 @@ renamedFields = applySubstitution conSubst' fields innerType' <- resolveTypeSynonyms renamedInnerType- case decomposeType innerType' of++ -- If the return type in the data constructor is of the form `T :: K`, then+ -- return (T, Just K, Just resKind), where `resKind` is the result kind of+ -- the parent data type. Otherwise, return (T :: K, Nothing, Nothing). The+ -- two `Maybe` values are passed below to `mergeArgumentKinds` such that if+ -- they are both `Just`, then we will attempt to unify `K` and `resKind`.+ -- See step (2) of Note [Tricky result kinds].+ let (innerType'', mbInnerResKind, mbResKind) =+ case innerType' of+ SigT t innerResKind -> (t, Just innerResKind, Just resKind)+ _ -> (innerType', Nothing, Nothing)++ case decomposeType innerType'' of ConT innerTyCon :| ts | typename == innerTyCon -> - let (substName, context1) =+ let -- See step (2) of Note [Tricky result kinds].+#if MIN_VERSION_template_haskell(2,8,0)+ instTys' = maybeToList mbResKind ++ instTys+ ts' = maybeToList mbInnerResKind ++ ts+#else+ instTys' = instTys+ ts' = ts+#endif++ (substName, context1) = closeOverKinds (kindsOfFVsOfTvbs renamedTyvars) (kindsOfFVsOfTvbs params)- (mergeArguments instTys ts)+ (mergeArguments instTys' ts') subst = VarT <$> substName exTyvars = [ tv | tv <- renamedTyvars, Map.notMember (tvName tv) subst ] @@ -1525,29 +1783,233 @@ 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+-- Reconstruct a function type from its type variable binders, context,+-- argument types and return type.+curryType :: [TyVarBndrSpec] -> Cxt -> [Type] -> Type -> Type+curryType tvbs ctxt args res =+ ForallT tvbs ctxt $ foldr (\arg t -> ArrowT `AppT` arg `AppT` t) res args++-- All of the code from @ForallTelescope@ through @unravelType@ is taken from+-- the @th-desugar@ library, which is licensed under a 3-Clause BSD license.++-- | The type variable binders in a @forall@. This is not used by the TH AST+-- itself, but this is used as an intermediate data type in 'FAForalls'.+data ForallTelescope+ = ForallVis [TyVarBndrUnit]+ -- ^ A visible @forall@ (e.g., @forall a -> {...}@).+ -- These do not have any notion of specificity, so we use+ -- '()' as a placeholder value in the 'TyVarBndr's.+ | ForallInvis [TyVarBndrSpec]+ -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),+ -- where each binder has a 'Specificity'.++-- | The list of arguments in a function 'Type'.+data FunArgs+ = FANil+ -- ^ No more arguments.+ | FAForalls ForallTelescope FunArgs+ -- ^ A series of @forall@ed type variables followed by a dot (if+ -- 'ForallInvis') or an arrow (if 'ForallVis'). For example,+ -- the type variables @a1 ... an@ in @forall a1 ... an. r@.+ | FACxt Cxt FunArgs+ -- ^ A series of constraint arguments followed by @=>@. For example,+ -- the @(c1, ..., cn)@ in @(c1, ..., cn) => r@.+ | FAAnon Kind FunArgs+ -- ^ An anonymous argument followed by an arrow. For example, the @a@+ -- in @a -> r@.++-- | A /visible/ function argument type (i.e., one that must be supplied+-- explicitly in the source code). This is in contrast to /invisible/+-- arguments (e.g., the @c@ in @c => r@), which are instantiated without+-- the need for explicit user input.+data VisFunArg+ = VisFADep TyVarBndrUnit+ -- ^ A visible @forall@ (e.g., @forall a -> a@).+ | VisFAAnon Kind+ -- ^ An anonymous argument followed by an arrow (e.g., @a -> r@).++#if MIN_VERSION_template_haskell(2,8,0)+-- | Decompose a function 'Type' into its arguments (the 'FunArgs') and its+-- result type (the 'Type).+unravelType :: Type -> (FunArgs, Type)+unravelType (ForallT tvbs cxt ty) =+ let (args, res) = unravelType ty in+ (FAForalls (ForallInvis tvbs) (FACxt cxt args), res)+unravelType (AppT (AppT ArrowT t1) t2) =+ let (args, res) = unravelType t2 in+ (FAAnon t1 args, res)+# if __GLASGOW_HASKELL__ >= 809+unravelType (ForallVisT tvbs ty) =+ let (args, res) = unravelType ty in+ (FAForalls (ForallVis tvbs) args, res)+# endif+unravelType t = (FANil, t)++-- | Reconstruct an arrow 'Type' from its argument and result types.+ravelType :: FunArgs -> Type -> Type+ravelType FANil res = res+-- We need a special case for FAForalls ForallInvis followed by FACxt so that we may+-- collapse them into a single ForallT when raveling.+ravelType (FAForalls (ForallInvis tvbs) (FACxt p args)) res =+ ForallT tvbs p (ravelType args res)+ravelType (FAForalls (ForallInvis tvbs) args) res = ForallT tvbs [] (ravelType args res)+ravelType (FAForalls (ForallVis _tvbs) _args) _res =+#if __GLASGOW_HASKELL__ >= 809+ ForallVisT _tvbs (ravelType _args _res)+#else+ error "Visible dependent quantification supported only on GHC 8.10+"+#endif+ravelType (FACxt cxt args) res = ForallT [] cxt (ravelType args res)+ravelType (FAAnon t args) res = AppT (AppT ArrowT t) (ravelType args res)++-- | Convert a 'FunArg's value into the list of 'Type's that it contains.+-- For example, given this function type: ----- forall a b. Maybe a -> Maybe b -> Type+-- @+-- forall k (a :: k). Proxy a -> forall b. Maybe b+-- @ ----- becomes+-- Then calling @funArgTys@ on the arguments would yield: ----- ([a, b], [], [Maybe a, Maybe b] :|- Type)-uncurryKind :: Kind -> ([TyVarBndrSpec], Cxt, NonEmptySnoc Kind)+-- @+-- [k, (a :: k), Proxy a, b, Maybe b]+-- @+--+-- This is primarily used for the purposes of computing all of the type+-- variables that appear in a 'FunArgs' value.+funArgTys :: FunArgs -> [Type]+funArgTys FANil = []+funArgTys (FAForalls tele args) =+ forallTelescopeTys tele ++ funArgTys args+# if __GLASGOW_HASKELL__ >= 800+funArgTys (FACxt ctxt args) =+ ctxt ++ funArgTys args+# else+funArgTys (FACxt {}) =+ error "Constraints in kinds not supported prior to GHC 8.0"+# endif+funArgTys (FAAnon anon args) =+ anon : funArgTys args++-- | Convert a 'ForallTelescope' value into the list of 'Type's that it+-- contains. See the Haddocks for 'funArgTys' for an example of what this does.+forallTelescopeTys :: ForallTelescope -> [Type]+forallTelescopeTys (ForallVis tvbs) = bndrParams tvbs+forallTelescopeTys (ForallInvis tvbs) = bndrParams tvbs+#endif++-- | Reconstruct an arrow 'Kind' from its argument and result kinds.+ravelKind :: FunArgs -> Kind -> Kind #if MIN_VERSION_template_haskell(2,8,0)-uncurryKind = uncurryType+ravelKind = ravelType #else-uncurryKind = go []- where- go args (ArrowK k1 k2) = go (k1:args) k2- go args StarK = ([], [], reverse args :|- StarK)+ravelKind FANil res = res+ravelKind (FAAnon k args) res = ArrowK k (ravelKind args res)+ravelKind (FAForalls {}) _res =+ error "TH doesn't support `forall`s in kinds prior to template-haskell-2.8.0.0"+ravelKind (FACxt {}) _res =+ error "TH doesn't support contexts in kinds prior to template-haskell-2.8.0.0" #endif --- Reconstruct a function type from its type variable binders, context,--- argument types and return type.-curryType :: [TyVarBndrSpec] -> Cxt -> [Type] -> Type -> Type-curryType tvbs ctxt args res =- ForallT tvbs ctxt $ foldr (\arg t -> ArrowT `AppT` arg `AppT` t) res args+-- | Decompose a function 'Kind' into its arguments (the 'FunArgs') and its+-- result type (the 'Kind).+unravelKind :: Kind -> (FunArgs, Kind)+#if MIN_VERSION_template_haskell(2,8,0)+unravelKind = unravelType+#else+unravelKind (ArrowK k1 k2) =+ let (args, res) = unravelKind k2 in+ (FAAnon k1 args, res)+unravelKind StarK =+ (FANil, StarK)+#endif++-- | @'filterVisFunArgsUpTo' xs args@ will split @args@ into 'VisFunArg's as+-- many times as there are elements in @xs@, pairing up each entry in @xs@ with+-- the corresponding 'VisFunArg' in the process. This will stop after the last+-- entry in @xs@ has been paired up.+--+-- For example, this:+--+-- @+-- 'filterVisFunArgsUpTo'+-- [Bool, True]+-- [ FAForalls (ForallVis [j])+-- , FAAnon j+-- , FAForalls (ForallInvis [k])+-- , FAAnon k+-- ]+-- @+--+-- Will yield:+--+-- @+-- ( [(Bool, VisFADep j), (True, VisFAAnon j)]+-- , [FAForalls (ForallInvis [k]), FAAnon k]+-- )+-- @+--+-- This function assumes the precondition that there are at least as many+-- visible function arguments in @args@ as there are elements in @xs@. If this+-- is not the case, this function will raise an error.+filterVisFunArgsUpTo :: forall a. [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)+filterVisFunArgsUpTo = go_fun_args+ where+ go_fun_args :: [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)+ go_fun_args [] args =+ ([], args)+ go_fun_args (_:_) FANil =+ error "filterVisFunArgsUpTo.go_fun_args: Too few FunArgs"+ go_fun_args xs (FACxt _ args) =+ go_fun_args xs args+ go_fun_args (x:xs) (FAAnon t args) =+ let (xs', args') = go_fun_args xs args in+ ((x, VisFAAnon t):xs', args')+ go_fun_args xs (FAForalls tele args) =+ case tele of+ ForallVis tvbs ->+ go_vis_tvbs tvbs xs args+ ForallInvis _ ->+ go_fun_args xs args++ go_vis_tvbs :: [TyVarBndrUnit] -> [a] -> FunArgs -> ([(a, VisFunArg)], FunArgs)+ go_vis_tvbs [] xs args =+ go_fun_args xs args+ go_vis_tvbs (tvb:tvbs) (x:xs) args =+ let (xs', args') = go_vis_tvbs tvbs xs args in+ ((x, VisFADep tvb):xs', args')+ go_vis_tvbs tvbs [] args =+ ([], FAForalls (ForallVis tvbs) args)++-- | @'unravelKindUpTo' xs k@ will split the function kind @k@ into its argument+-- kinds @args@ and result kind @res@, and then it will call+-- @'filterVisFunArgsUpTo' xs args@. The leftover arguments that were not split+-- apart by 'filterVisFunArgsUpTo' are then raveled back into @res@.+--+-- For example, this:+--+-- @+-- 'filterVisFunArgsUpTo'+-- [Bool, True]+-- (forall j -> j -> forall k. k -> Type)+-- @+--+-- Will yield:+--+-- @+-- ( [(Bool, VisFADep j), (True, VisFAAnon j)]+-- , forall k. k -> Type+-- )+-- @+--+-- This function assumes the precondition that there are at least as many+-- visible function arguments in @args@ as there are elements in @xs@. If this+-- is not the case, this function will raise an error.+unravelKindUpTo :: [a] -> Kind -> ([(a, VisFunArg)], Kind)+unravelKindUpTo xs k = (xs', ravelKind args' res)+ where+ (args, res) = unravelKind k+ (xs', args') = filterVisFunArgsUpTo xs args -- | Resolve any infix type application in a type using the fixities that -- are currently available. Starting in `template-haskell-2.11` types could
test/Harness.hs view
@@ -47,10 +47,14 @@ 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 (bndrParams (datatypeVars dat2))) (map VarT (freeVariables (bndrParams (datatypeVars dat1)))))+ check "datatypeReturnKind"+ id+ (datatypeReturnKind dat1)+ (applySubstitution sub $ datatypeReturnKind dat2)+ check "datatypeCons len" (length . datatypeCons) dat1 dat2+ check "datatypeVars" id (datatypeVars dat1)
test/Main.hs view
@@ -1,9 +1,13 @@-{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs #-}+{-# Language CPP, FlexibleContexts, TypeFamilies, KindSignatures, TemplateHaskell, GADTs, RankNTypes, MagicHash #-} #if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE ConstraintKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 800 && __GLASGOW_HASKELL__ < 806+{-# Language TypeInType #-}+#endif+ #if __GLASGOW_HASKELL__ >= 807 {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-}@@ -17,6 +21,10 @@ {-# Language TypeAbstractions #-} #endif +#if MIN_VERSION_template_haskell(2,18,0)+{-# LANGUAGE UnliftedDatatypes #-}+#endif+ {-| Module : Main Description : Test cases for the th-abstraction package@@ -38,11 +46,24 @@ import Control.Monad (unless, when) import qualified Data.Map as Map +#if __GLASGOW_HASKELL__ >= 800+import Data.Kind+#endif #if MIN_VERSION_base(4,7,0) import Data.Type.Equality ((:~:)(..)) #endif -import Language.Haskell.TH+#if __GLASGOW_HASKELL__ >= 810+import GHC.Exts (Any, RuntimeRep(..), TYPE)+#endif+#if __GLASGOW_HASKELL__ >= 902+import GHC.Exts (UnliftedType, Levity(..))+#endif++import GHC.Exts (Array#)++import qualified Language.Haskell.TH as TH (Type)+import Language.Haskell.TH hiding (Type) import Language.Haskell.TH.Datatype as Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.Lib (starK)@@ -120,7 +141,22 @@ #if MIN_VERSION_template_haskell(2,21,0) t103Test #endif+#if __GLASGOW_HASKELL__ >= 810+ t107Test+ t108Test+#endif+#if __GLASGOW_HASKELL__ >= 804+ t110Test+#endif+#if MIN_VERSION_template_haskell(2,16,0)+ unboxedTupleTest+#endif+#if MIN_VERSION_template_haskell(2,18,0)+ unliftedGADTDecTest+#endif+ primTyConTest + adt1Test :: IO () adt1Test = $(do info <- reifyDatatype ''Adt1@@ -137,6 +173,7 @@ , datatypeVars = [aTvb,bTvb] , datatypeInstTypes = [aSig, bSig] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Adtc1@@ -170,6 +207,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT aVar starK] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Gadtc1@@ -217,6 +255,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT (VarT a) starK] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ con, con { constructorName = 'Gadtrecc2 } ] }@@ -238,6 +277,7 @@ , datatypeVars = [aTvb, bTvb, cTvb] , datatypeInstTypes = [aSig, bSig, cSig] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Equalc@@ -270,6 +310,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Showable@@ -292,6 +333,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'R1@@ -327,6 +369,7 @@ , datatypeVars = [aTvb, bTvb] , datatypeInstTypes = [aSig, bSig] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ con { constructorName = 'Gadt2c1 , constructorContext = [equalPred bVar (AppT ListT aVar)] }@@ -351,6 +394,7 @@ , datatypeVars = [kindedTV g (arrowKCompat starK starK)] , datatypeInstTypes = [SigT (VarT g) (arrowKCompat starK starK)] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [] } )@@ -365,6 +409,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'StrictDemo@@ -396,6 +441,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Plain"@@ -415,6 +461,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkT43Fam"@@ -439,6 +486,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkFoo"@@ -463,6 +511,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [AppT (ConT ''Maybe) (VarT a)] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'DFMaybe@@ -486,6 +535,7 @@ , datatypeVars = [kindedTV c starK] , datatypeInstTypes = [SigT cVar starK] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'DF1@@ -510,6 +560,7 @@ , datatypeVars = [plainTV a] , datatypeInstTypes = [aVar] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkQuoted"@@ -537,6 +588,7 @@ kindedTV a kVar ] , datatypeInstTypes = [SigT (VarT a) kVar] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkPoly@@ -562,6 +614,7 @@ , datatypeVars = [cTvb,dTvb] , datatypeInstTypes = [cSig,dSig] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkGadtFam1@@ -620,6 +673,7 @@ , datatypeVars = [] , datatypeInstTypes = [ConT ''Int] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec1Int"@@ -645,6 +699,7 @@ , datatypeVars = [aTvb,bTvb] , datatypeInstTypes = [ConT ''Int, TupleT 2 `AppT` aVar `AppT` bVar, aVar] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "FamLocalDec2Int"@@ -683,6 +738,7 @@ , datatypeVars = [bTvb] , datatypeInstTypes = [ConT ''Int, SigT bVar starK] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT73@@ -707,6 +763,7 @@ , datatypeVars = [aTvb] , datatypeInstTypes = [AppT ListT aVar] , datatypeVariant = DataInstance+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT95@@ -749,6 +806,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT (VarT a) starK] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Nothing@@ -787,6 +845,7 @@ kindedTV a kKind, kindedTV b kKind] , datatypeInstTypes = [SigT aVar kKind, SigT bVar kKind] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'Refl@@ -808,7 +867,7 @@ let ty = ForallT [kindedTVSpecified a (VarT k1)] [] (VarT a) substTy = applySubstitution (Map.singleton k1 (VarT k2)) ty - checkFreeVars :: Type -> [Name] -> Q ()+ checkFreeVars :: TH.Type -> [Name] -> Q () checkFreeVars t freeVars = unless (freeVariables t == freeVars) $ fail $ "free variables of " ++ show t ++ " should be " ++ show freeVars@@ -840,7 +899,7 @@ t61Test :: IO () t61Test =- $(do let test :: Type -> Type -> Q ()+ $(do let test :: TH.Type -> TH.Type -> Q () test orig expected = do actual <- resolveTypeSynonyms orig unless (expected == actual) $@@ -851,13 +910,13 @@ idAppT = (ConT ''Id `AppT`) a = mkName "a"- test (SigT (idAppT $ ConT ''Int) (idAppT StarT))- (SigT (ConT ''Int) StarT)+ test (SigT (idAppT $ ConT ''Int) (idAppT starK))+ (SigT (ConT ''Int) starK) #if MIN_VERSION_template_haskell(2,10,0)- test (ForallT [kindedTVSpecified a (idAppT StarT)]+ test (ForallT [kindedTVSpecified a (idAppT starK)] [idAppT (ConT ''Show `AppT` VarT a)] (idAppT $ VarT a))- (ForallT [kindedTVSpecified a StarT]+ (ForallT [kindedTVSpecified a starK] [ConT ''Show `AppT` VarT a] (VarT a)) #endif@@ -889,6 +948,7 @@ , datatypeInstTypes = [ VarT a, VarT b , SigT (VarT f) fKind, SigT (VarT x) starK ] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = mkName "MkFoo"@@ -974,6 +1034,7 @@ , datatypeVars = [kTvb, aTvb] , datatypeInstTypes = [kSig, aSig] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37a@@ -992,6 +1053,7 @@ , datatypeVars = [kTvb, aTvb] , datatypeInstTypes = [aSig] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37b@@ -1010,6 +1072,7 @@ , datatypeVars = [kTvb, aTvb] , datatypeInstTypes = [aSig] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT37c@@ -1033,6 +1096,7 @@ , datatypeVars = [kindedTV a starK] , datatypeInstTypes = [SigT aVar starK] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = 'MkT48@@ -1168,6 +1232,7 @@ , datatypeVars = [] , datatypeInstTypes = [] , datatypeVariant = Datatype.TypeData+ , datatypeReturnKind = starK , datatypeCons = [ ConstructorInfo { constructorName = ''MkT100@@ -1201,7 +1266,200 @@ , datatypeVars = [plainTV k, kindedTV a (VarT k)] , datatypeInstTypes = [SigT (VarT a) (VarT k)] , datatypeVariant = Datatype+ , datatypeReturnKind = starK , datatypeCons = [] } ) #endif++#if __GLASGOW_HASKELL__ >= 810+t107Test :: IO ()+t107Test =+ $(do info <- reifyDatatype ''T107+ let r = mkName "r"+ validateDI info+ DatatypeInfo+ { datatypeName = mkName "T107"+ , datatypeContext = []+ , datatypeVars = [kindedTV r (ConT ''RuntimeRep)]+ , datatypeInstTypes = []+ , datatypeVariant = Newtype+ , datatypeReturnKind = ConT ''TYPE `AppT` VarT r+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "MkT107"+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [ConT ''Any `SigT` (ConT ''TYPE `AppT` VarT r)]+ , constructorStrictness = [notStrictAnnot]+ , constructorVariant = NormalConstructor+ }+ ]+ }+ )++t108Test :: IO ()+t108Test =+ $(do [dec] <- [d| data T108 :: forall k -> k -> Type where+ MkT108 :: forall k (a :: k). T108 k a+ |]+ info <- normalizeDec dec+ let k = mkName "k"+ a = mkName "a"+ validateDI info+ DatatypeInfo+ { datatypeName = mkName "T108"+ , datatypeContext = []+ , datatypeVars = [plainTV k, kindedTV a (VarT k)]+ , datatypeInstTypes = [VarT k, SigT (VarT a) (VarT k)]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "MkT108"+ , constructorVars = []+ , constructorContext = []+ , constructorFields = []+ , constructorStrictness = []+ , constructorVariant = NormalConstructor+ }+ ]+ }+ )+#endif++#if __GLASGOW_HASKELL__ >= 804+t110Test :: IO ()+t110Test =+ $(do [dec] <- [d| data T110 :: forall k. k -> Type where+ MkT110 :: forall k (a :: k). T110 a+ |]+ info <- normalizeDec dec+ let k = mkName "k"+ a = mkName "a"+ validateDI info+ DatatypeInfo+ { datatypeName = mkName "T110"+ , datatypeContext = []+ , datatypeVars = [plainTV k, kindedTV a (VarT k)]+ , datatypeInstTypes = [SigT (VarT a) (VarT k)]+ , datatypeVariant = Datatype+ , datatypeReturnKind = starK+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = mkName "MkT110"+ , constructorVars = []+ , constructorContext = []+ , constructorFields = []+ , constructorStrictness = []+ , constructorVariant = NormalConstructor+ }+ ]+ }+ )+#endif++#if MIN_VERSION_template_haskell(2,16,0)+unboxedTupleTest :: IO ()+unboxedTupleTest =+ $(do k0 <- newName "k0"+ k1 <- newName "k1"+ a <- newName "a"+ b <- newName "b"+ tupleInfo <- reifyDatatype (unboxedTupleTypeName 2)+ validateDI tupleInfo+ DatatypeInfo + { datatypeContext = []+ , datatypeName = unboxedTupleTypeName 2+ , datatypeVars = [kindedTV k0 starK+ ,kindedTV a (AppT (ConT ''TYPE) (VarT k0 ))+ ,kindedTV k1 starK+ ,kindedTV b (AppT (ConT ''TYPE) (VarT k1))]+ , datatypeInstTypes = [SigT (VarT a) (AppT (ConT ''TYPE) (VarT k0))+ ,SigT (VarT b) (AppT (ConT ''TYPE) (VarT k1))]+ , datatypeVariant = Datatype+ , datatypeReturnKind =+ AppT+ (ConT ''TYPE)+ (AppT+ (PromotedT 'TupleRep)+ (AppT+ (AppT PromotedConsT (VarT k0))+ (AppT+ (AppT PromotedConsT (VarT k1))+ (SigT PromotedNilT (AppT ListT (ConT ''RuntimeRep))))))+ , datatypeCons =+ [ ConstructorInfo+ { constructorName = unboxedTupleDataName 2+ , constructorVars = []+ , constructorContext = []+ , constructorFields = [VarT a, VarT b]+ , constructorStrictness = [notStrictAnnot, notStrictAnnot]+ , constructorVariant = NormalConstructor}]+ }+ )+#endif++#if MIN_VERSION_template_haskell(2,18,0)+unliftedGADTDecTest :: IO ()+unliftedGADTDecTest =+ $(do a <- newName "a"+ s <- newName "s"+ [dec] <- [d| data UnliftedGADT a :: UnliftedType where+ UnliftedGADT :: Show s => s -> a -> UnliftedGADT a+ |]+ info <- normalizeDec dec+ validateDI info+ DatatypeInfo+ { datatypeContext = []+ , datatypeName = mkName "UnliftedGADT"+ , datatypeVars = [plainTV a]+ , datatypeInstTypes = [VarT a]+ , datatypeVariant = Datatype+ , datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted)+ , datatypeCons =+ [ConstructorInfo+ {constructorName = mkName "UnliftedGADT"+ , constructorVars = [plainTV s]+ , constructorContext = [AppT (ConT ''Show) (VarT s)]+ , constructorFields = [VarT s,VarT a]+ , constructorStrictness = [notStrictAnnot, notStrictAnnot]+ , constructorVariant = NormalConstructor}+ ]+ }+ )+#endif+++primTyConTest :: IO ()+primTyConTest =+ $(do l <- newName "l"+ a <- newName "a"+ info <- reifyDatatype ''Array#+ validateDI info+ DatatypeInfo+ { datatypeContext = []+ , datatypeName = mkName "Array#"+#if MIN_VERSION_template_haskell(2,19,0)+ , datatypeVars = [kindedTV l (ConT ''Levity)+ , kindedTV a (ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` VarT l))+ ]+ , datatypeInstTypes = [SigT (VarT a) (ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` VarT l))]+ , datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted)+#elif MIN_VERSION_template_haskell(2,18,0)+ , datatypeVars = [ kindedTV a StarT]+ , datatypeInstTypes = [SigT (VarT a) StarT]+ , datatypeReturnKind = ConT ''TYPE `AppT` (PromotedT 'BoxedRep `AppT` PromotedT 'Unlifted)+#elif MIN_VERSION_template_haskell(2,16,0)+ , datatypeVars = [kindedTV a starK]+ , datatypeInstTypes = [SigT (VarT a) starK]+ , datatypeReturnKind = ConT ''TYPE `AppT` PromotedT 'UnliftedRep+#else+ , datatypeVars = [kindedTV a starK]+ , datatypeInstTypes = [SigT (VarT a) starK]+ , datatypeReturnKind = starK+#endif+ , datatypeVariant = Datatype+ , datatypeCons = []+ }+ )
test/Types.hs view
@@ -15,6 +15,12 @@ # endif #endif +#if __GLASGOW_HASKELL__ >= 810+{-# Language StandaloneKindSignatures #-}+{-# Language TypeApplications #-}+{-# Language UnliftedNewtypes #-}+#endif+ #if MIN_VERSION_template_haskell(2,20,0) {-# Language TypeData #-} #endif@@ -45,6 +51,10 @@ import Data.Kind #endif +#if __GLASGOW_HASKELL__ >= 810+import GHC.Exts (Any, TYPE)+#endif+ type Gadt1Int = Gadt1 Int infixr 6 :**:@@ -144,9 +154,15 @@ data T37a (k :: Type) :: k -> Type where MkT37a :: T37a Bool a +# if __GLASGOW_HASKELL__ >= 810+type T37b :: k -> Type+# endif data T37b (a :: k) where MkT37b :: forall (a :: Bool). T37b a +# if __GLASGOW_HASKELL__ >= 810+type T37c :: k -> Type+# endif data T37c (a :: k) where MkT37c :: T37c Bool @@ -161,6 +177,12 @@ #if MIN_VERSION_template_haskell(2,20,0) type data T100 = MkT100+#endif++#if __GLASGOW_HASKELL__ >= 810+type T107 :: TYPE r+newtype T107 where+ MkT107 :: forall r. Any @(TYPE r) -> T107 @r #endif -- We must define these here due to Template Haskell staging restrictions
th-abstraction.cabal view
@@ -1,5 +1,5 @@ name: th-abstraction-version: 0.6.0.0+version: 0.7.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==9.6.2, GHC==9.4.5, GHC==9.2.7, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, 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==9.8.1, GHC==9.6.3, GHC==9.4.7, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, 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@@ -29,8 +29,8 @@ other-modules: Language.Haskell.TH.Datatype.Internal build-depends: base >=4.3 && <5, ghc-prim,- template-haskell >=2.5 && <2.22,- containers >=0.4 && <0.7+ template-haskell >=2.5 && <2.23,+ containers >=0.4 && <0.8 hs-source-dirs: src default-language: Haskell2010