commit 2d8649d85bb1c728e8521b3a9aa6ebb2ff09586f Author: Gabor Greif 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)