--- /dev/null
+commit 2d8649d85bb1c728e8521b3a9aa6ebb2ff09586f
+Author: Gabor Greif <ggreif@gmail.com>
+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)
+
+
--- /dev/null
+commit dbf14af22edd0636d4f9c8b083e42565bfcf99c9
+Author: Gabor Greif <ggreif@gmail.com>
+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
projects / gentoo.git / commitdiff