gienah 15/01/04 04:49:53
Added: th-expand-syns-0.3.0.4-ghc-7.10-1.patch
th-expand-syns-0.3.0.4-ghc-7.10-2.patch
Log:
Apply patch from upstream to allow th-expand-syns-0.3.0.4 to build with ghc
7.10
(Portage version: 2.2.15/cvs/Linux x86_64, signed Manifest commit with key
618E971F)
Revision Changes Path
1.1
dev-haskell/th-expand-syns/files/th-expand-syns-0.3.0.4-ghc-7.10-1.patch
file :
http://sources.gentoo.org/viewvc.cgi/gentoo-x86/dev-haskell/th-expand-syns/files/th-expand-syns-0.3.0.4-ghc-7.10-1.patch?rev=1.1&view=markup
plain:
http://sources.gentoo.org/viewvc.cgi/gentoo-x86/dev-haskell/th-expand-syns/files/th-expand-syns-0.3.0.4-ghc-7.10-1.patch?rev=1.1&content-type=text/plain
Index: th-expand-syns-0.3.0.4-ghc-7.10-1.patch
===================================================================
commit 2d8649d85bb1c728e8521b3a9aa6ebb2ff09586f
Author: Gabor Greif <[email protected]>
Date: Mon Jun 16 15:43:51 2014 +0200
M-x whitespace-cleanup
diff --git a/Language/Haskell/TH/ExpandSyns.hs
b/Language/Haskell/TH/ExpandSyns.hs
index 1110124..cc0dccf 100644
--- a/Language/Haskell/TH/ExpandSyns.hs
+++ b/Language/Haskell/TH/ExpandSyns.hs
@@ -7,9 +7,9 @@ module Language.Haskell.TH.ExpandSyns(-- * Expand synonyms
,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,26 @@ import Control.Monad
packagename :: String
packagename = "th-expand-syns"
-
-
+
+
-- Compatibility layer for TH >=2.4 vs. 2.3
tyVarBndrGetName :: TyVarBndr -> Name
mapPred :: (Type -> Type) -> Pred -> Pred
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
-
+
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
-
+
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 +48,7 @@ tyVarBndrGetName = id
mapPred = id
bindPred = id
tyVarBndrSetName n _ = n
-
+
#endif
@@ -70,29 +70,29 @@ nameIsSyn n = do
#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 +129,8 @@ expandSyns = \t ->
-- 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 +141,22 @@ expandSyns = \t ->
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 +165,20 @@ expandSyns = \t ->
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?)
)
@@ -213,11 +213,11 @@ instance SubstTypeVariable Type where
| 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
@@ -237,23 +237,23 @@ instance SubstTypeVariable Type where
#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)
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
--
@@ -268,7 +268,7 @@ instance SubstTypeVariable Pred where
-- 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 +276,11 @@ evade n t =
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 +300,7 @@ instance SubstTypeVariable Con where
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 +316,18 @@ instance HasForallConstruct Con where
-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 +336,11 @@ commonForallCase vt@(v,t) (bndrs,cxt,body)
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)
1.1
dev-haskell/th-expand-syns/files/th-expand-syns-0.3.0.4-ghc-7.10-2.patch
file :
http://sources.gentoo.org/viewvc.cgi/gentoo-x86/dev-haskell/th-expand-syns/files/th-expand-syns-0.3.0.4-ghc-7.10-2.patch?rev=1.1&view=markup
plain:
http://sources.gentoo.org/viewvc.cgi/gentoo-x86/dev-haskell/th-expand-syns/files/th-expand-syns-0.3.0.4-ghc-7.10-2.patch?rev=1.1&content-type=text/plain
Index: th-expand-syns-0.3.0.4-ghc-7.10-2.patch
===================================================================
commit dbf14af22edd0636d4f9c8b083e42565bfcf99c9
Author: Gabor Greif <[email protected]>
Date: Mon Jun 16 16:15:39 2014 +0200
Support for GHC HEAD (v7.9, aka. template-haskell-2.10)
Pred is a type synonym now, and EqualityT is new.
diff --git a/Language/Haskell/TH/ExpandSyns.hs
b/Language/Haskell/TH/ExpandSyns.hs
index cc0dccf..7a18c17 100644
--- a/Language/Haskell/TH/ExpandSyns.hs
+++ b/Language/Haskell/TH/ExpandSyns.hs
@@ -24,7 +24,9 @@ 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
@@ -32,11 +34,15 @@ tyVarBndrSetName :: Name -> TyVarBndr -> TyVarBndr
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
@@ -198,6 +204,10 @@ expandSyns = \t ->
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
@@ -236,6 +246,10 @@ instance SubstTypeVariable Type where
go s@(LitT _) = s
#endif
+#if MIN_VERSION_template_haskell(2,10,0)
+ go s@EqualityT = s
+#endif
+
-- testCapture :: Type
-- testCapture =
-- let
@@ -249,7 +263,7 @@ instance SubstTypeVariable Type where
-- (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
