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 @@ -7,9 +7,9 @@ ,substInType ,substInCon ,evades,evade) where - + import Language.Haskell.TH hiding(cxt) -import qualified Data.Set as Set +import qualified Data.Set as Set import Data.Generics import Control.Monad @@ -20,26 +20,32 @@ 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) - + bindPred f (ClassP n ts) = ClassP n <$> mapM f ts bindPred f (EqualP t1 t2) = EqualP <$> f t1 <*> f t2 - +#endif + tyVarBndrSetName n (PlainTV _) = PlainTV n -tyVarBndrSetName n (KindedTV _ k) = KindedTV n k +tyVarBndrSetName n (KindedTV _ k) = KindedTV n k #else type TyVarBndr = Name @@ -48,7 +54,7 @@ mapPred = id bindPred = id tyVarBndrSetName n _ = n - + #endif @@ -70,29 +76,29 @@ #if MIN_VERSION_template_haskell(2,7,0) FamilyI (FamilyD flavour name _ _) _ -> maybeWarnTypeFamily flavour name >> return Nothing #endif - _ -> do + _ -> 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 - + warn :: String -> Q () -warn msg = +warn msg = #if MIN_VERSION_template_haskell(2,8,0) reportWarning #else - report False + report False #endif (packagename ++": "++"WARNING: "++msg) #if MIN_VERSION_template_haskell(2,4,0) maybeWarnTypeFamily :: FamFlavour -> Name -> Q () -maybeWarnTypeFamily flavour name = +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) + 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 @@ -129,8 +135,8 @@ -- If @go args t = (args', t')@, -- - -- Precondition: - -- All elements of `args' are expanded. + -- 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) @@ -141,22 +147,22 @@ 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 _ _ _) = + 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) = + + go acc (AppT t1 t2) = do r <- expandSyns t2 go (r:acc) t1 - + go acc x@(ConT n) = do i <- nameIsSyn n @@ -165,20 +171,20 @@ Just (vars,body) -> if length acc < length vars then fail (packagename++": expandSyns: Underapplied type synonym: "++show(n,acc)) - else + 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) = + go acc (SigT t kind) = do (acc',t') <- go acc t - return - (acc', + return + (acc', SigT t' kind -- No expansion needed in kinds (todo: is this correct?) ) @@ -198,6 +204,10 @@ go acc x@(LitT _) = passThrough acc x #endif +#if MIN_VERSION_template_haskell(2,10,0) + go acc x@EqualityT = passThrough acc x +#endif + class SubstTypeVariable a where -- | Capture-free substitution subst :: (Name, Type) -> a -> a @@ -213,11 +223,11 @@ | otherwise = s go ArrowT = ArrowT go ListT = ListT - go (ForallT vars cxt body) = + 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 #endif @@ -236,25 +246,29 @@ go s@(LitT _) = s #endif +#if MIN_VERSION_template_haskell(2,10,0) + go s@EqualityT = s +#endif + -- testCapture :: Type --- testCapture = --- let +-- testCapture = +-- let -- n = mkName -- v = VarT . mkName -- in -- substInType (n "x", v "y" `AppT` v "z") --- (ForallT --- [n "y",n "z"] +-- (ForallT +-- [n "y",n "z"] -- [ConT (mkName "Show") `AppT` v "x" `AppT` v "z"] -- (v "x" `AppT` v "y")) - -#if MIN_VERSION_template_haskell(2,4,0) + +#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 - + -- | Make a name (based on the first arg) that's distinct from every name in the second arg -- -- Example why this is necessary: @@ -268,7 +282,7 @@ -- AST using 'mkName' to ensure a collision. -- evade :: Data d => Name -> d -> Name -evade n t = +evade n t = let vars :: Set.Set Name vars = everything Set.union (mkQ Set.empty Set.singleton) t @@ -276,11 +290,11 @@ go n1 = if n1 `Set.member` vars then go (bump n1) else n1 - + bump = mkName . ('f':) . nameBase in go n - + -- | Make a list of names (based on the first arg) such that every name in the result -- is distinct from every name in the second arg, and from the other results evades :: (Data t) => [Name] -> t -> [Name] @@ -300,7 +314,7 @@ 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) = + go (ForallC vars cxt body) = commonForallCase (v,t) (vars,cxt,body) @@ -316,18 +330,18 @@ -commonForallCase :: (SubstTypeVariable a, HasForallConstruct a) => +commonForallCase :: (SubstTypeVariable a, HasForallConstruct a) => - (Name,Type) + (Name,Type) -> ([TyVarBndr],Cxt,a) -> a commonForallCase vt@(v,t) (bndrs,cxt,body) - -- If a variable with the same name as the one to be replaced is bound by the forall, + -- 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` (tyVarBndrGetName <$> bndrs) = mkForall bndrs cxt body - | otherwise = + | otherwise = let -- prevent capture vars = tyVarBndrGetName <$> bndrs @@ -336,11 +350,11 @@ substs = zip vars (VarT <$> freshes) doSubsts :: SubstTypeVariable b => b -> b doSubsts x = foldr subst x substs - + in - mkForall + mkForall freshTyVarBndrs - (fmap (subst vt . doSubsts) cxt ) + (fmap (subst vt . doSubsts) cxt ) ( (subst vt . doSubsts) body) diff --git a/changelog.markdown b/changelog.markdown new file mode 100644 --- /dev/null +++ b/changelog.markdown @@ -0,0 +1,3 @@ +## 0.3.0.5 + +* 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 @@ -2,51 +2,52 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} -- {-# OPTIONS -ddump-splices #-} -module Main where import Language.Haskell.TH.ExpandSyns import Language.Haskell.TH import Language.Haskell.TH.Syntax import Util - --- type A = forall a. B a; type B a = Maybe a; expand [t|B A|] - -type ListOf x = [x] -type ForAll f = forall x. f x -type ApplyToInteger f = f Integer -type Int' = Int -type Either' = Either -type Int'' = Int - -$(sequence [tySynD (mkName "E") [PlainTV (mkName "x")] - (forallT'' ["y"] (conT ''Either `appT` varT' "x" `appT` varT' "y" --> conT ''Int)) - ]) - - -data family DF1 a - -data instance DF1 Int = DInt (ListOf ()) - -type family TF1 a - -type instance TF1 Int = ListOf () - -class Class1 a where - type AT1 a - -instance Class1 Int where type AT1 Int = ListOf () +import Types main = do + $(do + i <- reify ''ForAll + runIO . putStrLn . show $ i + [| return () |]) + putStrLn "Basic test..." $(mkTest [t| forall a. Show a => a -> ForAll [] -> (Int,ApplyToInteger []) |] - [t| forall a. Show a => a -> (forall x. [] x) -> (Int,[] Integer) |]) +-- 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 + + ) + 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 + expectedExpansion = - forallT'' ["y_0"] (conT ''Either `appT` varT' "y" `appT` varT' "y_0" --> conT ''Int) + 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 diff --git a/testing/Types.hs b/testing/Types.hs new file mode 100644 --- /dev/null +++ b/testing/Types.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE KindSignatures #-} +module Types where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Util + +-- type A = forall a. B a; type B a = Maybe a; expand [t|B A|] + +type ListOf x = [x] +type ForAll f = forall x. f x +type ApplyToInteger f = f Integer +type Int' = Int +type Either' = Either +type Int'' = Int + +-- type E x = forall y. Either x y -> Int +$(sequence [tySynD (mkName "E") [PlainTV (mkName "x")] + (forallT'' ["y"] (conT ''Either `appT` varT' "x" `appT` varT' "y" --> conT ''Int)) + ]) + + +data family DF1 a + +data instance DF1 Int = DInt (ListOf ()) + +type family TF1 a + +type instance TF1 Int = ListOf () + +class Class1 a where + type AT1 a + +instance Class1 Int where type AT1 Int = ListOf () diff --git a/testing/Util.hs b/testing/Util.hs new file mode 100644 --- /dev/null +++ b/testing/Util.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TemplateHaskell #-} +module Util where +import Language.Haskell.TH +import Language.Haskell.TH.ExpandSyns + +mkTest :: Q Type -> Q Type -> Q Exp +mkTest input expected = + do + input' <- input + runIO . putStrLn $ ("info: input = "++show input') + 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" |] + + +forallT' xs = forallT ((PlainTV . mkName) `fmap` xs) +forallT'' xs = forallT' xs (cxt []) +varT' = varT . mkName +conT' = conT . mkName + +x --> y = (arrowT `appT` x) `appT` y +infixr 5 --> diff --git a/th-expand-syns.cabal b/th-expand-syns.cabal --- a/th-expand-syns.cabal +++ b/th-expand-syns.cabal @@ -1,21 +1,28 @@ name: th-expand-syns -version: 0.3.0.4 +version: 0.3.0.5 synopsis: Expands type synonyms in Template Haskell ASTs description: Expands type synonyms in Template Haskell ASTs category: Template Haskell license: BSD3 license-file: LICENSE author: Daniel Schüssler -maintainer: daniels@community.haskell.org -cabal-version: >= 1.6 +maintainer: haskell.5wlh@gishpuppy.com +cabal-version: >= 1.8 build-type: Simple -extra-source-files: testing/Main.hs +extra-source-files: changelog.markdown source-repository head type: git location: git://github.com/DanielSchuessler/th-expand-syns.git Library - build-depends: base >= 4 && < 5, template-haskell, syb, containers + build-depends: base >= 4 && < 5, template-haskell < 2.11, syb, containers ghc-options: exposed-modules: Language.Haskell.TH.ExpandSyns + +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