th-expand-syns 0.3.0.4 → 0.3.0.5
raw patch · 6 files changed
+171/−85 lines, 6 filesdep +th-expand-synsdep ~basedep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies added: th-expand-syns
Dependency ranges changed: base, template-haskell
API changes (from Hackage documentation)
Files
- Language/Haskell/TH/ExpandSyns.hs +64/−50
- changelog.markdown +3/−0
- testing/Main.hs +31/−30
- testing/Types.hs +37/−0
- testing/Util.hs +24/−0
- th-expand-syns.cabal +12/−5
Language/Haskell/TH/ExpandSyns.hs view
@@ -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)
+ changelog.markdown view
@@ -0,0 +1,3 @@+## 0.3.0.5++* Fixed build with GHC 7.10.1-rc2 / template-haskell-2.10 (Thanks to Gabor Greif)
testing/Main.hs view
@@ -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
+ testing/Types.hs view
@@ -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 ()
+ testing/Util.hs view
@@ -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 -->
th-expand-syns.cabal view
@@ -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