diff --git a/readme.md b/readme.md new file mode 100644 --- /dev/null +++ b/readme.md @@ -0,0 +1,10 @@ +# th-extras +[![Haskell](https://img.shields.io/badge/language-Haskell-orange.svg)](https://haskell.org) [![Hackage](https://img.shields.io/hackage/v/th-extras.svg)](https://hackage.haskell.org/package/th-extras) [![Hackage CI](https://matrix.hackage.haskell.org/api/v2/packages/th-extras/badge)](https://matrix.hackage.haskell.org/#/package/th-extras) [![Github CI](https://github.com/mokus0/th-extras/workflows/github-action/badge.svg)](https://github.com/mokus0/th-extras/actions) [![BSD3 License](https://img.shields.io/badge/license-BSD3-blue.svg)](https://github.com/mokus0/th-extras/blob/master/LICENSE) + +A grab bag of useful functions for use with Template Haskell. + +This is basically the place I put all my ugly CPP hacks to support the +ever-changing interface of the template haskell system by providing high-level +operations and making sure they work on as many versions of Template Haskell as +I can. + diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs --- a/src/Language/Haskell/TH/Extras.hs +++ b/src/Language/Haskell/TH/Extras.hs @@ -4,11 +4,14 @@ import Control.Monad import Data.Generics import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set import Language.Haskell.TH import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Datatype.TyVarBndr intIs64 :: Bool -intIs64 = toInteger (maxBound :: Int) > 2^32 +intIs64 = toInteger (maxBound :: Int) > 2^(32 :: Integer) replace :: (a -> Maybe a) -> (a -> a) replace = ap fromMaybe @@ -18,6 +21,9 @@ composeExprs [f] = f composeExprs (f:fs) = [| $f . $(composeExprs fs) |] +-- | Determines the name of a data constructor. It's an error if the 'Con' binds more than one name (which +-- happens in the case where you use GADT syntax, and give multiple data constructor names separated by commas +-- in a type signature in the where clause). nameOfCon :: Con -> Name nameOfCon (NormalC name _) = name nameOfCon (RecC name _) = name @@ -25,7 +31,9 @@ nameOfCon (ForallC _ _ con) = nameOfCon con #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 nameOfCon (GadtC [name] _ _) = name +nameOfCon (GadtC _ _ _) = error $ "nameOfCon: GadtC: only single constructor names are supported" nameOfCon (RecGadtC [name] _ _) = name +nameOfCon (RecGadtC _ _ _) = error $ "nameOfCon: RecGadtC: only single constructor names are supported" #endif -- |WARNING: discards binders in GADTs and existentially-quantified constructors @@ -39,16 +47,10 @@ argTypesOfCon (RecGadtC _ args _) = [t | (_,_,t) <- args] #endif -nameOfBinder :: TyVarBndr -> Name -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700 -nameOfBinder (PlainTV n) = n -nameOfBinder (KindedTV n _) = n -#else -nameOfBinder = id -type TyVarBndr = Name -#endif +nameOfBinder :: TyVarBndr_ a -> Name +nameOfBinder = tvName -varsBoundInCon :: Con -> [TyVarBndr] +varsBoundInCon :: Con -> [TyVarBndrSpec] varsBoundInCon (ForallC bndrs _ con) = bndrs ++ varsBoundInCon con varsBoundInCon _ = [] @@ -116,7 +118,7 @@ genericalizeDecs decs = everywhere (mkT fixName) decs where -- get all names bound in the decs and make them generic - -- at every occurence in decs. + -- at every occurrence in decs. names = decs >>= namesBoundInDec genericalizedNames = [ (n, genericalizeName n) | n <- names] fixName = replace (`lookup` genericalizedNames) @@ -129,28 +131,155 @@ headOfType ArrowT = ''(->) headOfType ListT = ''[] headOfType (AppT t _) = headOfType t - #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 headOfType (SigT t _) = headOfType t #endif - #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 headOfType (UnboxedTupleT n) = unboxedTupleTypeName n #endif +#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 +headOfType ty = error $ "headOfType: Unhandled type: " ++ show ty +#endif occursInType :: Name -> Type -> Bool occursInType var ty = case ty of - ForallT bndrs _ ty - | any (var ==) (map nameOfBinder bndrs) + ForallT bndrs _ ty' + | any (var ==) (map tvName bndrs) -> False | otherwise - -> occursInType var ty + -> occursInType var ty' VarT name | name == var -> True | otherwise -> False AppT ty1 ty2 -> occursInType var ty1 || occursInType var ty2 #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 - SigT ty _ -> occursInType var ty + SigT ty' _ -> occursInType var ty' #endif _ -> False +-- | Assuming that we're building an instance of the form C (T v_1 ... v_(n-1)) for some GADT T, this function +-- takes a list of the variables v_1 ... v_(n-1) used in the instance head, as well as the result type of some data +-- constructor, say T x_1 ... x_(n-1) x_n, as well as the type t of some argument to it, and substitutes any of +-- x_i (1 <= i <= n-1) occurring in t for the corresponding v_i, taking care to avoid name capture by foralls in t. +substVarsWith + :: [Name] -- Names of variables used in the instance head in argument order + -> Type -- Result type of constructor + -> Type -- Type of argument to the constructor + -> Type -- Type of argument with variables substituted for instance head variables. +substVarsWith topVars resultType argType = subst Set.empty argType + where + topVars' = reverse topVars + AppT resultType' _indexType = resultType + subst :: Set Name -> Type -> Type + subst bs ty = case ty of + -- Several of the following cases could all be covered by an "x -> x" case, but + -- I'd rather know if new cases need to be handled specially in future versions + -- of Template Haskell. +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 710 + ForallT bndrs cxt t -> + let bs' = Set.union bs (Set.fromList (map tvName bndrs)) + in ForallT bndrs (map (subst bs') cxt) (subst bs' t) +#else + ForallT {} -> error "substVarsWith: ForallT substitutions have not been implemented for GHCs prior to 7.10" +#endif + AppT f x -> AppT (subst bs f) (subst bs x) + SigT t k -> SigT (subst bs t) k + VarT v -> if Set.member v bs + then VarT v + else VarT (findVar v topVars' resultType') + ConT n -> ConT n + TupleT k -> TupleT k + ArrowT -> ArrowT + ListT -> ListT +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 + InfixT t1 x t2 -> InfixT (subst bs t1) x (subst bs t2) + ParensT t -> ParensT (subst bs t) + UInfixT t1 x t2 -> UInfixT (subst bs t1) x (subst bs t2) + UnboxedSumT k -> UnboxedSumT k + WildCardT -> WildCardT +#endif +#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 710 + EqualityT -> EqualityT +#endif +#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 + ConstraintT -> ConstraintT + LitT l -> LitT l + PromotedConsT -> PromotedConsT + PromotedNilT -> PromotedNilT + PromotedT n -> PromotedT n + PromotedTupleT k -> PromotedTupleT k + StarT -> StarT +#endif +#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 700 + UnboxedTupleT k -> UnboxedTupleT k +#endif + findVar v (tv:_) (AppT _ (VarT v')) | v == v' = tv + findVar v (_:tvs) (AppT t (VarT _)) = findVar v tvs t + findVar v _ _ = error $ "substVarsWith: couldn't look up variable substitution for " ++ show v + ++ " with topVars: " ++ show topVars ++ " resultType: " ++ show resultType ++ " argType: " ++ show argType + +-- | Determine the arity of a kind. +-- Starting in template-haskell 2.8.0.0, 'Kind' and 'Type' became synonymous. +kindArity :: Kind -> Int +#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706 +kindArity k = case k of + StarK -> 0 + ArrowK _ k2 -> 1 + kindArity k2 +#else +kindArity k = case k of + ForallT _ _ t -> kindArity t + AppT (AppT ArrowT _) t -> 1 + kindArity t + SigT t _ -> kindArity t +#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 + ParensT t -> kindArity t +#endif + _ -> 0 +#endif + +-- | Given the name of a type constructor, determine its full arity +tyConArity :: Name -> Q Int +tyConArity n = do + (ts, ka) <- tyConArity' n + return (length ts + ka) + +-- | Given the name of a type constructor, determine a list of type variables bound as parameters by +-- its declaration, and the arity of the kind of type being defined (i.e. how many more arguments would +-- need to be supplied in addition to the bound parameters in order to obtain an ordinary type of kind *). +-- If the supplied 'Name' is anything other than a data or newtype, produces an error. +tyConArity' :: Name -> Q ([TyVarBndrUnit], Int) +tyConArity' n = do + r <- reify n + return $ case r of +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 + TyConI (DataD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) + TyConI (NewtypeD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) +#else + TyConI (DataD _ _ ts _ _) -> (ts, 0) + TyConI (NewtypeD _ _ ts _ _) -> (ts, 0) +#endif + _ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " ++ show n + +-- | Determine the constructors bound by a data or newtype declaration. Errors out if supplied with another +-- sort of declaration. +decCons :: Dec -> [Con] +decCons d = case d of +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 + DataD _ _ _ _ cs _ -> cs + NewtypeD _ _ _ _ c _ -> [c] +#else + DataD _ _ _ cs _ -> cs + NewtypeD _ _ _ c _ -> [c] +#endif + _ -> error "decCons: Declaration found was not a data or newtype declaration." + +-- | Determine the arity of a data constructor. +conArity :: Con -> Int +conArity c = case c of + NormalC _ ts -> length ts + RecC _ ts -> length ts + InfixC _ _ _ -> 2 + ForallC _ _ c' -> conArity c' +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 + GadtC _ ts _ -> length ts + RecGadtC _ ts _ -> length ts +#endif diff --git a/th-extras.cabal b/th-extras.cabal --- a/th-extras.cabal +++ b/th-extras.cabal @@ -1,8 +1,8 @@ name: th-extras -version: 0.0.0.4 +version: 0.0.0.5 stability: experimental -cabal-version: >= 1.6 +cabal-version: >= 1.10 build-type: Simple author: James Cook @@ -19,9 +19,11 @@ providing high-level operations and making sure they work on as many versions of Template Haskell as I can. -tested-with: GHC == 6.8.3, GHC == 6.10.4, GHC == 6.12.3, - GHC == 7.0.4, GHC == 7.2.1, GHC == 7.2.2 +tested-with: GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, + GHC == 8.8.4, GHC == 8.10.2, GHC == 9.0.1 +extra-source-files: readme.md + source-repository head type: git location: https://github.com/mokus0/th-extras.git @@ -33,7 +35,10 @@ hs-source-dirs: src exposed-modules: Language.Haskell.TH.Extras build-depends: base >= 3 && < 5, - template-haskell - + containers, + template-haskell < 2.18, + th-abstraction >= 0.4 && < 0.5 + default-language: Haskell2010 + if flag(base4) build-depends: base >= 4, syb