+++ /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