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 @@ -16,6 +16,7 @@ import Language.Haskell.TH hiding(cxt) import qualified Data.Set as Set import Data.Generics +import Data.Maybe import Control.Monad import Prelude @@ -201,6 +202,10 @@ go (PatSynSigD {}) = no #endif +#if MIN_VERSION_template_haskell(2,15,0) + go (ImplicitParamBindD {}) = no +#endif + no = return Nothing #if MIN_VERSION_template_haskell(2,4,0) @@ -229,8 +234,39 @@ expandSyns' t = do (acc,t') <- go [] t - return (foldl AppT t' acc) + return (foldl applyTypeArg t' acc) +#if MIN_VERSION_template_haskell(2,4,0) + expandKindSyns' k = +# if MIN_VERSION_template_haskell(2,8,0) + do + (acc,k') <- go [] k + return (foldl applyTypeArg k' acc) +# else + return k -- No kind variables on old versions of GHC +# endif +#endif + + applyTypeArg :: Type -> TypeArg -> Type + applyTypeArg f (TANormal x) = f `AppT` x + applyTypeArg f (TyArg _x) = +#if __GLASGOW_HASKELL__ >= 807 + f `AppKindT` _x +#else + -- VKA isn't supported, so + -- conservatively drop the argument + f +#endif + + + -- Filter the normal type arguments from a list of TypeArgs. + filterTANormals :: [TypeArg] -> [Type] + filterTANormals = mapMaybe getTANormal + where + getTANormal :: TypeArg -> Maybe Type + getTANormal (TANormal t) = Just t + getTANormal (TyArg {}) = Nothing + -- Must only be called on an `x' requiring no expansion passThrough acc x = return (acc, x) @@ -242,7 +278,7 @@ -- 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 :: [TypeArg] -> Type -> Q ([TypeArg], Type) go acc x@ListT = passThrough acc x go acc x@ArrowT = passThrough acc x @@ -262,7 +298,7 @@ go acc (AppT t1 t2) = do r <- expandSyns' t2 - go (r:acc) t1 + go (TANormal r:acc) t1 go acc x@(ConT n) = do @@ -274,7 +310,7 @@ then fail (packagename++": expandSynsWith: Underapplied type synonym: "++show(n,acc)) else let - substs = zip vars acc + substs = zip vars (filterTANormals acc) expanded = foldr subst body substs in go (drop (length vars) acc) expanded @@ -284,11 +320,8 @@ 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?) - ) + kind' <- expandKindSyns' kind + return (acc', SigT t' kind') #endif #if MIN_VERSION_template_haskell(2,6,0) @@ -331,6 +364,24 @@ go acc x@(UnboxedSumT _) = passThrough acc x #endif +#if MIN_VERSION_template_haskell(2,15,0) + go acc (AppKindT t k) = + do + k' <- expandKindSyns' k + go (TyArg k':acc) t + go acc (ImplicitParamT n t) = + do + (acc',t') <- go acc t + return (acc',ImplicitParamT n t') +#endif + +-- | An argument to a type, either a normal type ('TANormal') or a visible +-- kind application ('TyArg'). +data TypeArg + = TANormal Type -- Normal arguments + | TyArg Kind -- Visible kind applications + deriving Show + class SubstTypeVariable a where -- | Capture-free substitution subst :: (Name, Type) -> a -> a @@ -352,7 +403,7 @@ go s@(TupleT _) = s #if MIN_VERSION_template_haskell(2,4,0) - go (SigT t1 kind) = SigT (go t1) kind + go (SigT t1 kind) = SigT (go t1) (subst (v, t) kind) #endif #if MIN_VERSION_template_haskell(2,6,0) @@ -384,6 +435,11 @@ go s@(UnboxedSumT _) = s #endif +#if MIN_VERSION_template_haskell(2,15,0) + go (AppKindT ty ki) = AppKindT (go ty) (go ki) + go (ImplicitParamT n ty) = ImplicitParamT n (go ty) +#endif + -- testCapture :: Type -- testCapture = -- let @@ -402,6 +458,10 @@ subst s = mapPred (subst s) #endif +#if MIN_VERSION_template_haskell(2,4,0) && !MIN_VERSION_template_haskell(2,8,0) +instance SubstTypeVariable Kind where + subst _ = id -- No kind variables on old versions of GHC +#endif -- | Make a name (based on the first arg) that's distinct from every name in the second arg -- diff --git a/changelog.markdown b/changelog.markdown --- a/changelog.markdown +++ b/changelog.markdown @@ -1,3 +1,8 @@ +## 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). diff --git a/testing/Main.hs b/testing/Main.hs --- a/testing/Main.hs +++ b/testing/Main.hs @@ -68,6 +68,13 @@ [t| Int'' |] [t| Int |]) +#if MIN_VERSION_template_haskell(2,8,0) + putStrLn "Synonyms in kinds" + $(mkTest + (sigT (conT ''Int) (ConT ''Id `AppT` StarT)) + (sigT (conT ''Int) StarT)) +#endif + $(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') |] diff --git a/testing/Types.hs b/testing/Types.hs --- a/testing/Types.hs +++ b/testing/Types.hs @@ -16,6 +16,7 @@ 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")] diff --git a/th-expand-syns.cabal b/th-expand-syns.cabal --- a/th-expand-syns.cabal +++ b/th-expand-syns.cabal @@ -1,5 +1,5 @@ name: th-expand-syns -version: 0.4.4.0 +version: 0.4.5.0 synopsis: Expands type synonyms in Template Haskell ASTs description: Expands type synonyms in Template Haskell ASTs. category: Template Haskell @@ -12,21 +12,18 @@ extra-source-files: changelog.markdown homepage: https://github.com/DanielSchuessler/th-expand-syns tested-with: - GHC == 7.0.4 - GHC == 7.2.2 - GHC == 7.4.2 - GHC == 7.6.3 - GHC == 7.8.4 - GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.1 source-repository head type: git location: git://github.com/DanielSchuessler/th-expand-syns.git Library - build-depends: base >= 4 && < 5, template-haskell < 2.14, syb, containers + build-depends: base >= 4 && < 5, template-haskell < 2.16, syb, containers ghc-options: exposed-modules: Language.Haskell.TH.ExpandSyns other-modules: Language.Haskell.TH.ExpandSyns.SemigroupCompat