th-expand-syns 0.3.0.6 → 0.4.12.0
raw patch · 7 files changed
Files
- LICENSE +1/−1
- Language/Haskell/TH/ExpandSyns.hs +178/−264
- changelog.markdown +70/−2
- testing/Main.hs +28/−26
- testing/Types.hs +3/−2
- testing/Util.hs +23/−7
- th-expand-syns.cabal +40/−8
LICENSE view
@@ -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:
Language/Haskell/TH/ExpandSyns.hs view
@@ -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
changelog.markdown view
@@ -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)
testing/Main.hs view
@@ -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 () |])+++
testing/Types.hs view
@@ -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)) ])
testing/Util.hs view
@@ -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+
th-expand-syns.cabal view
@@ -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 <ryan.gl.scott@gmail.com>+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