diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009, Daniel Schüssler +Copyright (c) 2009, Daniel Schüssler; 2021, Ryan Scott All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/Language/Haskell/TH/ExpandSyns.hs b/Language/Haskell/TH/ExpandSyns.hs --- a/Language/Haskell/TH/ExpandSyns.hs +++ b/Language/Haskell/TH/ExpandSyns.hs @@ -1,274 +1,204 @@ -{-# OPTIONS -Wall -fno-warn-unused-binds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} module Language.Haskell.TH.ExpandSyns(-- * Expand synonyms expandSyns + ,expandSynsWith + ,SynonymExpansionSettings + ,noWarnTypeFamilies + -- * Misc utilities ,substInType ,substInCon ,evades,evade) where +import Language.Haskell.TH.Datatype +import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH hiding(cxt) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Semigroup as Sem import qualified Data.Set as Set import Data.Generics import Control.Monad - --- For ghci -#ifndef MIN_VERSION_template_haskell -#define MIN_VERSION_template_haskell(X,Y,Z) 1 -#endif +import Prelude packagename :: String packagename = "th-expand-syns" - --- Compatibility layer for TH >=2.4 vs. 2.3 -tyVarBndrGetName :: TyVarBndr -> Name -#if !MIN_VERSION_template_haskell(2,10,0) -mapPred :: (Type -> Type) -> Pred -> Pred -#endif -bindPred :: (Type -> Q Type) -> Pred -> Q Pred -tyVarBndrSetName :: Name -> TyVarBndr -> TyVarBndr - -#if MIN_VERSION_template_haskell(2,4,0) -tyVarBndrGetName (PlainTV n) = n -tyVarBndrGetName (KindedTV n _) = n - -#if MIN_VERSION_template_haskell(2,10,0) -bindPred = id -#else -mapPred f (ClassP n ts) = ClassP n (f <$> ts) -mapPred f (EqualP t1 t2) = EqualP (f t1) (f t2) +tyVarBndrSetName :: Name -> TyVarBndr_ flag -> TyVarBndr_ flag +tyVarBndrSetName n = mapTVName (const n) -bindPred f (ClassP n ts) = ClassP n <$> mapM f ts -bindPred f (EqualP t1 t2) = EqualP <$> f t1 <*> f t2 -#endif +data SynonymExpansionSettings = + SynonymExpansionSettings { + sesWarnTypeFamilies :: Bool + } -tyVarBndrSetName n (PlainTV _) = PlainTV n -tyVarBndrSetName n (KindedTV _ k) = KindedTV n k -#else +instance Semigroup SynonymExpansionSettings where + SynonymExpansionSettings w1 <> SynonymExpansionSettings w2 = + SynonymExpansionSettings (w1 && w2) -type TyVarBndr = Name -type Pred = Type -tyVarBndrGetName = id -mapPred = id -bindPred = id -tyVarBndrSetName n _ = n +-- | Default settings ('mempty'): +-- +-- * Warn if type families are encountered. +-- +-- (The 'mappend' is currently rather useless; the monoid instance is intended for additional settings in the future). +instance Monoid SynonymExpansionSettings where + mempty = + SynonymExpansionSettings { + sesWarnTypeFamilies = True + } +#if !MIN_VERSION_base(4,11,0) +-- starting with base-4.11, mappend definitions are redundant; +-- at some point `mappend` will be removed from `Monoid` + mappend = (Sem.<>) #endif - -#if __GLASGOW_HASKELL__ < 709 -(<$>) :: (Functor f) => (a -> b) -> f a -> f b -(<$>) = fmap -#endif -(<*>) :: (Monad m) => m (a -> b) -> m a -> m b -(<*>) = ap +-- | Suppresses the warning that type families are unsupported. +noWarnTypeFamilies :: SynonymExpansionSettings +noWarnTypeFamilies = mempty { sesWarnTypeFamilies = False } -type SynInfo = ([Name],Type) +warn :: String -> Q () +warn msg = reportWarning (packagename ++": WARNING: "++msg) -nameIsSyn :: Name -> Q (Maybe SynInfo) -nameIsSyn n = do +warnIfNameIsTypeFamily :: Name -> Q () +warnIfNameIsTypeFamily n = do i <- reify n case i of - TyConI d -> decIsSyn d - ClassI {} -> return Nothing - PrimTyConI {} -> return Nothing -#if MIN_VERSION_template_haskell(2,7,0) - FamilyI (FamilyD flavour name _ _) _ -> maybeWarnTypeFamily flavour name >> return Nothing + ClassI {} -> return () + ClassOpI {} -> return () + TyConI d -> warnIfDecIsTypeFamily d + FamilyI d _ -> warnIfDecIsTypeFamily d -- Called for warnings + PrimTyConI {} -> return () + DataConI {} -> return () + VarI {} -> return () + TyVarI {} -> return () +#if MIN_VERSION_template_haskell(2,12,0) + PatSynI {} -> return () #endif - _ -> do - warn ("Don't know how to interpret the result of reify "++show n++" (= "++show i++").\n"++ - "I will assume that "++show n++" is not a type synonym.") - return Nothing - +warnIfDecIsTypeFamily :: Dec -> Q () +warnIfDecIsTypeFamily = go + where + go (TySynD {}) = return () + go (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) = maybeWarnTypeFamily name + go (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) = maybeWarnTypeFamily name + go (FunD {}) = return () + go (ValD {}) = return () + go (DataD {}) = return () + go (NewtypeD {}) = return () + go (ClassD {}) = return () + go (InstanceD {}) = return () + go (SigD {}) = return () + go (ForeignD {}) = return () + go (InfixD {}) = return () + go (PragmaD {}) = return () + -- Nothing to expand for data families, so no warning + go (DataFamilyD {}) = return () + go (DataInstD {}) = return () + go (NewtypeInstD {}) = return () + go (TySynInstD {}) = return () + go (RoleAnnotD {}) = return () + go (StandaloneDerivD {}) = return () + go (DefaultSigD {}) = return () -warn :: String -> Q () -warn msg = -#if MIN_VERSION_template_haskell(2,8,0) - reportWarning -#else - report False +#if MIN_VERSION_template_haskell(2,12,0) + go (PatSynD {}) = return () + go (PatSynSigD {}) = return () #endif - (packagename ++": "++"WARNING: "++msg) - -#if MIN_VERSION_template_haskell(2,4,0) -maybeWarnTypeFamily :: FamFlavour -> Name -> Q () -maybeWarnTypeFamily flavour name = - case flavour of - TypeFam -> - warn ("Type synonym families (and associated type synonyms) are currently not supported (they won't be expanded). Name of unsupported family: "++show name) - - DataFam -> return () - -- Nothing to expand for data families, so no warning +#if MIN_VERSION_template_haskell(2,15,0) + go (ImplicitParamBindD {}) = return () #endif --- | Handles only declaration constructs that can be returned by 'reify'ing a type name. -decIsSyn :: Dec -> Q (Maybe SynInfo) -decIsSyn (ClassD {}) = return Nothing -decIsSyn (DataD {}) = return Nothing -decIsSyn (NewtypeD {}) = return Nothing -decIsSyn (TySynD _ vars t) = return (Just (tyVarBndrGetName <$> vars,t)) -#if MIN_VERSION_template_haskell(2,4,0) -decIsSyn (FamilyD flavour name _ _) = maybeWarnTypeFamily flavour name >> return Nothing -#endif -decIsSyn x = do - warn ("Unrecognized declaration construct: "++ show x++". I will assume that it's not a type synonym declaration.") - return Nothing - - - - - --- | Expands all type synonyms in the given type. Type families currently won't be expanded (but will be passed through). -expandSyns :: Type -> Q Type -expandSyns = \t -> - do - (acc,t') <- go [] t - return (foldl AppT t' acc) - - - where - -- Must only be called on an `x' requiring no expansion - passThrough acc x = return (acc, x) - - -- If @go args t = (args', t')@, - -- - -- Precondition: - -- All elements of `args' are expanded. - -- Postcondition: - -- All elements of `args'' and `t'' are expanded. - -- `t' applied to `args' equals `t'' applied to `args'' (up to expansion, of course) - - go :: [Type] -> Type -> Q ([Type], Type) - - go acc x@ListT = passThrough acc x - go acc x@ArrowT = passThrough acc x - go acc x@(TupleT _) = passThrough acc x - go acc x@(VarT _) = passThrough acc x - - go [] (ForallT ns cxt t) = do - cxt' <- mapM (bindPred expandSyns) cxt - t' <- expandSyns t - return ([], ForallT ns cxt' t') - - go acc x@(ForallT _ _ _) = - fail (packagename++": Unexpected application of the local quantification: " - ++show x - ++"\n (to the arguments "++show acc++")") - - go acc (AppT t1 t2) = - do - r <- expandSyns t2 - go (r:acc) t1 - - go acc x@(ConT n) = - do - i <- nameIsSyn n - case i of - Nothing -> return (acc, x) - Just (vars,body) -> - if length acc < length vars - then fail (packagename++": expandSyns: Underapplied type synonym: "++show(n,acc)) - else - let - substs = zip vars acc - expanded = foldr subst body substs - in - go (drop (length vars) acc) expanded - - -#if MIN_VERSION_template_haskell(2,4,0) - go acc (SigT t kind) = - do - (acc',t') <- go acc t - return - (acc', - SigT t' kind - -- No expansion needed in kinds (todo: is this correct?) - ) +#if MIN_VERSION_template_haskell(2,16,0) + go (KiSigD {}) = return () #endif -#if MIN_VERSION_template_haskell(2,6,0) - go acc x@(UnboxedTupleT _) = passThrough acc x +#if MIN_VERSION_template_haskell(2,19,0) + go (DefaultD {}) = return () #endif -#if MIN_VERSION_template_haskell(2,8,0) - go acc x@(PromotedT _) = passThrough acc x - go acc x@(PromotedTupleT _) = passThrough acc x - go acc x@PromotedConsT = passThrough acc x - go acc x@PromotedNilT = passThrough acc x - go acc x@StarT = passThrough acc x - go acc x@ConstraintT = passThrough acc x - go acc x@(LitT _) = passThrough acc x +#if MIN_VERSION_template_haskell(2,20,0) + go (TypeDataD {}) = return () #endif -#if MIN_VERSION_template_haskell(2,10,0) - go acc x@EqualityT = passThrough acc x +warnTypeFamiliesInType :: Type -> Q () +warnTypeFamiliesInType = go + where + go :: Type -> Q () + go (ConT n) = warnIfNameIsTypeFamily n + go (AppT t1 t2) = go t1 >> go t2 + go (SigT t k) = go t >> go k + go ListT{} = return () + go ArrowT{} = return () + go VarT{} = return () + go TupleT{} = return () + go (ForallT tvbs ctxt body) = do + mapM_ (go . tvKind) tvbs + mapM_ go ctxt + go body + go UnboxedTupleT{} = return () + go PromotedT{} = return () + go PromotedTupleT{} = return () + go PromotedConsT{} = return () + go PromotedNilT{} = return () + go StarT{} = return () + go ConstraintT{} = return () + go LitT{} = return () + go EqualityT{} = return () + go (InfixT t1 n t2) = do + warnIfNameIsTypeFamily n + go t1 + go t2 + go (UInfixT t1 n t2) = do + warnIfNameIsTypeFamily n + go t1 + go t2 + go (ParensT t) = go t + go WildCardT{} = return () +#if MIN_VERSION_template_haskell(2,12,0) + go UnboxedSumT{} = return () #endif - -class SubstTypeVariable a where - -- | Capture-free substitution - subst :: (Name, Type) -> a -> a - - - -instance SubstTypeVariable Type where - subst (v, t) = go - where - go (AppT x y) = AppT (go x) (go y) - go s@(ConT _) = s - go s@(VarT w) | v == w = t - | otherwise = s - go ArrowT = ArrowT - go ListT = ListT - go (ForallT vars cxt body) = - commonForallCase (v,t) (vars,cxt,body) - - go s@(TupleT _) = s - -#if MIN_VERSION_template_haskell(2,4,0) - go (SigT t1 kind) = SigT (go t1) kind +#if MIN_VERSION_template_haskell(2,15,0) + go (AppKindT t k) = go t >> go k + go (ImplicitParamT _ t) = go t #endif - -#if MIN_VERSION_template_haskell(2,6,0) - go s@(UnboxedTupleT _) = s +#if MIN_VERSION_template_haskell(2,16,0) + go (ForallVisT tvbs body) = do + mapM_ (go . tvKind) tvbs + go body #endif - -#if MIN_VERSION_template_haskell(2,8,0) - go s@(PromotedT _) = s - go s@(PromotedTupleT _) = s - go s@PromotedConsT = s - go s@PromotedNilT = s - go s@StarT = s - go s@ConstraintT = s - go s@(LitT _) = s +#if MIN_VERSION_template_haskell(2,17,0) + go MulArrowT{} = return () #endif - -#if MIN_VERSION_template_haskell(2,10,0) - go s@EqualityT = s +#if MIN_VERSION_template_haskell(2,19,0) + go (PromotedInfixT t1 n t2) = do + warnIfNameIsTypeFamily n + go t1 + go t2 + go (PromotedUInfixT t1 n t2) = do + warnIfNameIsTypeFamily n + go t1 + go t2 #endif --- testCapture :: Type --- testCapture = --- let --- n = mkName --- v = VarT . mkName --- in --- substInType (n "x", v "y" `AppT` v "z") --- (ForallT --- [n "y",n "z"] --- [ConT (mkName "Show") `AppT` v "x" `AppT` v "z"] --- (v "x" `AppT` v "y")) - +maybeWarnTypeFamily :: Name -> Q () +maybeWarnTypeFamily name = + warn ("Type synonym families (and associated type synonyms) are currently not supported (they won't be expanded). Name of unsupported family: "++show name) -#if MIN_VERSION_template_haskell(2,4,0) && !MIN_VERSION_template_haskell(2,10,0) -instance SubstTypeVariable Pred where - subst s = mapPred (subst s) -#endif +-- | Calls 'expandSynsWith' with the default settings. +expandSyns :: Type -> Q Type +expandSyns = expandSynsWith mempty +-- | Expands all type synonyms in the given type. Type families currently won't be expanded (but will be passed through). +expandSynsWith :: SynonymExpansionSettings -> Type -> Q Type +expandSynsWith settings = expandSyns' + where + expandSyns' x = do + when (sesWarnTypeFamilies settings) $ + warnTypeFamiliesInType x + resolveTypeSynonyms x -- | Make a name (based on the first arg) that's distinct from every name in the second arg -- @@ -307,63 +237,47 @@ -- in -- evade v (AppT (VarT v) (VarT (mkName "fx"))) -instance SubstTypeVariable Con where - subst (v,t) = go +-- | Capture-free substitution +substInType :: (Name,Type) -> Type -> Type +substInType vt = applySubstitution (Map.fromList [vt]) + +-- | Capture-free substitution +substInCon :: (Name,Type) -> Con -> Con +substInCon vt = go where - st = subst (v,t) + vtSubst = Map.fromList [vt] + st = applySubstitution vtSubst go (NormalC n ts) = NormalC n [(x, st y) | (x,y) <- ts] go (RecC n ts) = RecC n [(x, y, st z) | (x,y,z) <- ts] go (InfixC (y1,t1) op (y2,t2)) = InfixC (y1,st t1) op (y2,st t2) go (ForallC vars cxt body) = - commonForallCase (v,t) (vars,cxt,body) - - - -class HasForallConstruct a where - mkForall :: [TyVarBndr] -> Cxt -> a -> a - -instance HasForallConstruct Type where - mkForall = ForallT - -instance HasForallConstruct Con where - mkForall = ForallC - - + commonForallCase vt vars $ \vts' vars' -> + ForallC (map (mapTVKind (applySubstitution vts')) vars') + (applySubstitution vts' cxt) + (Map.foldrWithKey (\v t -> substInCon (v, t)) body vts') + go c@GadtC{} = errGadt c + go c@RecGadtC{} = errGadt c -commonForallCase :: (SubstTypeVariable a, HasForallConstruct a) => + errGadt c = error (packagename++": substInCon currently doesn't support GADT constructors with GHC >= 8 ("++pprint c++")") - (Name,Type) - -> ([TyVarBndr],Cxt,a) +-- Apply a substitution to something underneath a @forall@. The continuation +-- argument provides new substitutions and fresh type variable binders to avoid +-- the outer substitution from capturing the thing underneath the @forall@. +commonForallCase :: (Name, Type) -> [TyVarBndr_ flag] + -> (Map Name Type -> [TyVarBndr_ flag] -> a) -> a -commonForallCase vt@(v,t) (bndrs,cxt,body) - +commonForallCase vt@(v,t) bndrs k -- If a variable with the same name as the one to be replaced is bound by the forall, -- the variable to be replaced is shadowed in the body, so we leave the whole thing alone (no recursion) - | v `elem` (tyVarBndrGetName <$> bndrs) = mkForall bndrs cxt body + | v `elem` (tvName <$> bndrs) = k (Map.fromList [vt]) bndrs | otherwise = let -- prevent capture - vars = tyVarBndrGetName <$> bndrs + vars = tvName <$> bndrs freshes = evades vars t freshTyVarBndrs = zipWith tyVarBndrSetName freshes bndrs substs = zip vars (VarT <$> freshes) - doSubsts :: SubstTypeVariable b => b -> b - doSubsts x = foldr subst x substs - in - mkForall - freshTyVarBndrs - (fmap (subst vt . doSubsts) cxt ) - ( (subst vt . doSubsts) body) - - - --- | Capture-free substitution -substInType :: (Name,Type) -> Type -> Type -substInType = subst - --- | Capture-free substitution -substInCon :: (Name,Type) -> Con -> Con -substInCon = subst + k (Map.fromList (vt:substs)) freshTyVarBndrs diff --git a/changelog.markdown b/changelog.markdown --- a/changelog.markdown +++ b/changelog.markdown @@ -1,7 +1,75 @@ +## 0.4.12.0 [2024.12.05] + +* Drop support for pre-8.0 versions of GHC. + +## 0.4.11.0 [2023.01.31] + +* Support `TypeDataD` when building with `template-haskell-2.20.0.0` (GHC 9.6) + or later. + +## 0.4.10.0 [2022.07.23] + +* Support `DefaultD`, `PromotedInfixT`, and `PromotedUInfixT` when building + with `template-haskell-2.19.0.0` (GHC 9.4) or later. + +## 0.4.9.0 [2021.08.30] + +* Consolidate the type-synonym expansion functionality with `th-abstraction`, + which also provides the ability to expand type synonyms. After this change, + the `th-expand-syns` library is mostly a small shim on top of + `th-abstraction`. The only additional pieces of functionality that + `th-expand-syns` which aren't currently available in `th-abstraction` are: + + * `th-expand-syns`' `expandSyns{With}` functions will warn that they cannot + expand type families (if the `SynonymExpansionSettings` are configured to + check for this). By contrast, `th-abstraction`'s `applySubstitution` + function will silently ignore type families. + * `th-expand-syns` provides a `substInCon` function which allows substitution + into `Con`s. + * `th-expand-syns` provides `evade{s}` functions which support type variable + `Name` freshening that calculating the free variables in any type that + provides an instance of `Data`. + +## 0.4.8.0 [2021.03.12] + +* Make the test suite compile with GHC 9.0 or later. +* Drop support for pre-7.0 versions of GHC. + +## 0.4.7.0 + +* Support GHC 9.0 / template-haskell-2.17 (Thanks to @mgsloan) + +## 0.4.5.0 + +* Support GHC 8.8 / template-haskell-2.15 (Thanks to Ryan Scott) +* Support GHC 8.6 / template-haskell-2.14 (Thanks to Chaitanya Koparkar) + +## 0.4.4.0 + +* Made `SynonymExpansionSettings` an instance of `Semigroup` (fixes build with GHC 8.4.1 alpha). + +## 0.4.3.0 + +* Added support for GHC 8.2.1 / template-haskell-2.12 (Thanks to Ryan Scott) + +## 0.4.2.0 + +* Eliminated warnings about unrecognized results of 'reify'. + +## 0.4.1.0 + +* Added a setting for suppressing warnings about type families. + +## 0.4.0.0 + +* Fixed build with GHC 8 / template-haskell-2.11 (Thanks to Christiaan Baaij) + + Note: `substInCon` doesn't support GADT constructors with GHC 8 in this version + ## 0.3.0.6 -* Fixed build with current (commit 029a296a770addbd096bbfd6de0936327ee620d4) GHC 7.10 (Thanks to David Fox) +* Fixed build with current (commit 029a296a770addbd096bbfd6de0936327ee620d4) GHC 7.10 (Thanks to David Fox) ## 0.3.0.5 -* Fixed build with GHC 7.10.1-rc2 / template-haskell-2.10 (Thanks to Gabor Greif) +* Fixed build with GHC 7.10.1-rc2 / template-haskell-2.10 (Thanks to Gabor Greif) diff --git a/testing/Main.hs b/testing/Main.hs --- a/testing/Main.hs +++ b/testing/Main.hs @@ -3,50 +3,39 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} --- {-# OPTIONS -ddump-splices #-} +import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.ExpandSyns import Language.Haskell.TH -import Language.Haskell.TH.Syntax import Util -import Types - +import Types +main :: IO () main = do putStrLn "Basic test..." - $(mkTest [t| forall a. Show a => a -> ForAll [] -> (Int,ApplyToInteger []) |] + $(mkTest [t| forall a. Show a => a -> ForAll [] -> (Int,ApplyToInteger []) |] --- GHC 7.8 always seems to consider the body of 'ForallT' to have a 'PlainTV', --- whereas it always has a 'KindedTV' with GHC 7.10 (in both cases, it doesn't appear +-- GHC 7.8 always seems to consider the body of 'ForallT' to have a 'PlainTV', +-- whereas it always has a 'KindedTV' with GHC 7.10 (in both cases, it doesn't appear -- to matter whether the definition of 'ForAll' is actually written with a kind signature). -#if MIN_VERSION_template_haskell(2,10,0) - [t| forall a. Show a => a -> (forall (x :: *). [] x) -> (Int,[] Integer) |] -#else - [t| forall a. Show a => a -> (forall x. [] x) -> (Int,[] Integer) |] -#endif - - ) + [t| forall a. Show a => a -> (forall (x :: *). [] x) -> (Int,[] Integer) |]) putStrLn "Variable capture avoidance test..." $(let -- See comment about 'PlainTV'/'KindedTV' above -#if MIN_VERSION_template_haskell(2,10,0) - y_0 = KindedTV (mkName "y_0") StarT -#else - y_0 = PlainTV (mkName "y_0") -#endif + y_0 = kindedTVSpecified (mkName "y_0") StarT expectedExpansion = - forallT - [y_0] + forallT + [y_0] (cxt []) (conT ''Either `appT` varT' "y" `appT` varT' "y_0" --> conT ''Int) -- the naive (and wrong) result would be: -- forall y. (forall y. Either y y -> Int) in - mkTest (forallT'' ["y"] (conT' "E" `appT` varT' "y")) + mkTest (forallT'' ["y"] (conT' "E" `appT` varT' "y")) (forallT'' ["y"] expectedExpansion)) putStrLn "Testing that it doesn't crash on type families (expanding them is not supported yet)" @@ -54,17 +43,30 @@ t = [t| (DF1 Int, TF1 Int, AT1 Int) |] in mkTest t t) - - putStrLn "Testing that the args of type family applications are handled" + + putStrLn "Testing that the args of type family applications are handled" $(mkTest [t| (DF1 Int', TF1 Int', AT1 Int') |] [t| (DF1 Int, TF1 Int, AT1 Int) |]) putStrLn "Higher-kinded synonym" - $(mkTest + $(mkTest [t| Either' (ListOf Int') (ListOf Char) |] [t| Either [Int] [Char] |]) putStrLn "Nested" - $(mkTest + $(mkTest [t| Int'' |] [t| Int |]) + + putStrLn "Synonyms in kinds" + $(mkTest + (sigT (conT ''Int) (ConT ''Id `AppT` StarT)) + (sigT (conT ''Int) StarT)) + + $(do + reportWarning "No warning about type families should appear after this line." -- TODO: Automate this test with a custom Quasi instance? + _ <- expandSynsWith noWarnTypeFamilies =<< [t| (DF1 Int', TF1 Int', AT1 Int') |] + [| return () |]) + + + diff --git a/testing/Types.hs b/testing/Types.hs --- a/testing/Types.hs +++ b/testing/Types.hs @@ -4,7 +4,7 @@ {-# LANGUAGE KindSignatures #-} module Types where -import Language.Haskell.TH +import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax import Util @@ -16,9 +16,10 @@ type Int' = Int type Either' = Either type Int'' = Int +type Id a = a -- type E x = forall y. Either x y -> Int -$(sequence [tySynD (mkName "E") [PlainTV (mkName "x")] +$(sequence [tySynD (mkName "E") [plainTV (mkName "x")] (forallT'' ["y"] (conT ''Either `appT` varT' "x" `appT` varT' "y" --> conT ''Int)) ]) diff --git a/testing/Util.hs b/testing/Util.hs --- a/testing/Util.hs +++ b/testing/Util.hs @@ -1,24 +1,40 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Util where -import Language.Haskell.TH -import Language.Haskell.TH.ExpandSyns +import Language.Haskell.TH +import Language.Haskell.TH.Datatype.TyVarBndr +import Language.Haskell.TH.ExpandSyns mkTest :: Q Type -> Q Type -> Q Exp mkTest input expected = do - input' <- input + input' <- input runIO . putStrLn $ ("info: input = "++show input') - expected' <- expected + expected' <- expected runIO . putStrLn $ ("info: expected = "++show expected') actual <- expandSyns input' runIO . putStrLn $ ("info: actual = "++show actual) - if (pprint expected'==pprint actual) then [| putStrLn "Ok" |] else [| error "expected /= actual" |] + if (pprint expected'==pprint actual) then [| putStrLn "Ok" |] else [| error "expected /= actual" |] -forallT' xs = forallT ((PlainTV . mkName) `fmap` xs) -forallT'' xs = forallT' xs (cxt []) +forallT' :: [String] -> Q Cxt -> Q Type -> Q Type +forallT' xs = forallT ((plainTVSpecified . mkName) `fmap` xs) + +forallT'' :: [String] -> Q Type -> Q Type +forallT'' xs = forallT' xs (cxt []) + +varT' :: String -> Q Type varT' = varT . mkName + +conT' :: String -> Q Type conT' = conT . mkName +(-->) :: Q Type -> Q Type -> Q Type x --> y = (arrowT `appT` x) `appT` y infixr 5 --> + +#if !MIN_VERSION_template_haskell(2,8,0) +reportWarning :: String -> Q () +reportWarning = report False +#endif + diff --git a/th-expand-syns.cabal b/th-expand-syns.cabal --- a/th-expand-syns.cabal +++ b/th-expand-syns.cabal @@ -1,28 +1,60 @@ name: th-expand-syns -version: 0.3.0.6 +version: 0.4.12.0 synopsis: Expands type synonyms in Template Haskell ASTs -description: Expands type synonyms in Template Haskell ASTs +description: Expands type synonyms in Template Haskell ASTs. + . + As of version @0.4.9.0@, this library is a small shim on + top of the @applySubstitution@/@resolveTypeSynonyms@ + functions from @th-abstraction@, so you may want to + consider using @th-abstraction@ instead. category: Template Haskell license: BSD3 license-file: LICENSE author: Daniel Schüssler -maintainer: haskell.5wlh@gishpuppy.com -cabal-version: >= 1.8 +maintainer: Ryan Scott +cabal-version: >= 1.10 build-type: Simple extra-source-files: changelog.markdown +homepage: https://github.com/DanielSchuessler/th-expand-syns +tested-with: + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.7 + GHC == 9.0.2 + GHC == 9.2.8 + GHC == 9.4.8 + GHC == 9.6.6 + GHC == 9.8.4 + GHC == 9.10.1 + GHC == 9.12.1 source-repository head type: git - location: git://github.com/DanielSchuessler/th-expand-syns.git + location: https://github.com/DanielSchuessler/th-expand-syns.git Library - build-depends: base >= 4 && < 5, template-haskell < 2.11, syb, containers - ghc-options: + build-depends: base >= 4.9 && < 5 + , containers + , syb + , th-abstraction >= 0.4.3 && < 0.8 + , template-haskell >= 2.11 && < 2.24 + ghc-options: -Wall exposed-modules: Language.Haskell.TH.ExpandSyns + default-language: Haskell2010 Test-Suite test-th-expand-syns type: exitcode-stdio-1.0 hs-source-dirs: testing main-is: Main.hs other-modules: Util, Types - build-depends: base, th-expand-syns, template-haskell + build-depends: base + , template-haskell + , th-abstraction + , th-expand-syns + ghc-options: -Wall + if impl(ghc >= 8.6) + ghc-options: -Wno-star-is-type + default-language: Haskell2010