diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/src/Language/Haskell/TH/Datatype.hs b/src/Language/Haskell/TH/Datatype.hs --- a/src/Language/Haskell/TH/Datatype.hs +++ b/src/Language/Haskell/TH/Datatype.hs @@ -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 diff --git a/test/Harness.hs b/test/Harness.hs --- a/test/Harness.hs +++ b/test/Harness.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 = [] + } + ) diff --git a/test/Types.hs b/test/Types.hs --- a/test/Types.hs +++ b/test/Types.hs @@ -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 diff --git a/th-abstraction.cabal b/th-abstraction.cabal --- a/th-abstraction.cabal +++ b/th-abstraction.cabal @@ -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