th-expand-syns-0.4.0.0/0000755000000000000000000000000012676267743012745 5ustar0000000000000000th-expand-syns-0.4.0.0/changelog.markdown0000644000000000000000000000061012676267743016435 0ustar0000000000000000## 0.4.0.0 * Fixed build with GHC 8 / template-haskell-2.11 (Thanks to Christiaan Baaij) Note: `substInCon` doesn't support GADT constructor with GHC 8 in this version ## 0.3.0.6 * Fixed build with current (commit 029a296a770addbd096bbfd6de0936327ee620d4) GHC 7.10 (Thanks to David Fox) ## 0.3.0.5 * Fixed build with GHC 7.10.1-rc2 / template-haskell-2.10 (Thanks to Gabor Greif) th-expand-syns-0.4.0.0/Setup.lhs0000644000000000000000000000011412676267743014551 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain th-expand-syns-0.4.0.0/th-expand-syns.cabal0000644000000000000000000000172412676267743016617 0ustar0000000000000000name: th-expand-syns version: 0.4.0.0 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: haskell.5wlh@gishpuppy.com cabal-version: >= 1.8 build-type: Simple 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 < 2.12, 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 th-expand-syns-0.4.0.0/LICENSE0000644000000000000000000000272512676267743013760 0ustar0000000000000000Copyright (c) 2009, Daniel Schüssler All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. th-expand-syns-0.4.0.0/Language/0000755000000000000000000000000012676267743014470 5ustar0000000000000000th-expand-syns-0.4.0.0/Language/Haskell/0000755000000000000000000000000012676267743016053 5ustar0000000000000000th-expand-syns-0.4.0.0/Language/Haskell/TH/0000755000000000000000000000000012676267743016366 5ustar0000000000000000th-expand-syns-0.4.0.0/Language/Haskell/TH/ExpandSyns.hs0000644000000000000000000003012312676267743021015 0ustar0000000000000000{-# OPTIONS -Wall -fno-warn-unused-binds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} module Language.Haskell.TH.ExpandSyns(-- * Expand synonyms expandSyns -- * Misc utilities ,substInType ,substInCon ,evades,evade) where import Language.Haskell.TH hiding(cxt) import qualified Data.Set as Set import Data.Generics import Control.Monad -- For ghci #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(X,Y,Z) 1 #endif 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 #else type TyVarBndr = Name type Pred = Type tyVarBndrGetName = id mapPred = id bindPred = id tyVarBndrSetName n _ = n #endif #if __GLASGOW_HASKELL__ < 709 (<$>) :: (Functor f) => (a -> b) -> f a -> f b (<$>) = fmap #endif (<*>) :: (Monad m) => m (a -> b) -> m a -> m b (<*>) = ap type SynInfo = ([Name],Type) nameIsSyn :: Name -> Q (Maybe SynInfo) nameIsSyn n = do i <- reify n case i of TyConI d -> decIsSyn d ClassI {} -> return Nothing PrimTyConI {} -> return Nothing #if MIN_VERSION_template_haskell(2,11,0) FamilyI (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) _ -> maybeWarnTypeFamily TypeFam name >> return Nothing FamilyI (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) _ -> maybeWarnTypeFamily TypeFam name >> return Nothing FamilyI (DataFamilyD _ _ _) _ -> return Nothing #elif MIN_VERSION_template_haskell(2,7,0) FamilyI (FamilyD flavour name _ _) _ -> maybeWarnTypeFamily flavour name >> return Nothing #endif _ -> 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 = #if MIN_VERSION_template_haskell(2,8,0) reportWarning #else report False #endif (packagename ++": "++"WARNING: "++msg) #if MIN_VERSION_template_haskell(2,4,0) maybeWarnTypeFamily :: FamFlavour -> Name -> Q () 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) DataFam -> return () -- Nothing to expand for data families, so no warning #endif -- | Handles only declaration constructs that can be returned by 'reify'ing a type name. decIsSyn :: Dec -> Q (Maybe SynInfo) decIsSyn (ClassD {}) = return Nothing decIsSyn (DataD {}) = return Nothing decIsSyn (NewtypeD {}) = return Nothing decIsSyn (TySynD _ vars t) = return (Just (tyVarBndrGetName <$> vars,t)) #if MIN_VERSION_template_haskell(2,11,0) decIsSyn (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) = maybeWarnTypeFamily TypeFam name >> return Nothing decIsSyn (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) = maybeWarnTypeFamily TypeFam name >> return Nothing decIsSyn (DataFamilyD _ _ _) = return Nothing #elif MIN_VERSION_template_haskell(2,4,0) decIsSyn (FamilyD flavour name _ _) = maybeWarnTypeFamily flavour name >> return Nothing #endif decIsSyn x = do warn ("Unrecognized declaration construct: "++ show x++". I will assume that it's not a type synonym declaration.") return Nothing -- | Expands all type synonyms in the given type. Type families currently won't be expanded (but will be passed through). expandSyns :: Type -> Q Type expandSyns = \t -> do (acc,t') <- go [] t return (foldl AppT t' acc) where -- Must only be called on an `x' requiring no expansion passThrough acc x = return (acc, x) -- If @go args t = (args', t')@, -- -- 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) go :: [Type] -> Type -> Q ([Type], Type) go acc x@ListT = passThrough acc x 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 _ _ _) = fail (packagename++": Unexpected application of the local quantification: " ++show x ++"\n (to the arguments "++show acc++")") go acc (AppT t1 t2) = do r <- expandSyns t2 go (r:acc) t1 go acc x@(ConT n) = do i <- nameIsSyn n case i of Nothing -> return (acc, x) Just (vars,body) -> if length acc < length vars then fail (packagename++": expandSyns: Underapplied type synonym: "++show(n,acc)) 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) = do (acc',t') <- go acc t return (acc', SigT t' kind -- No expansion needed in kinds (todo: is this correct?) ) #endif #if MIN_VERSION_template_haskell(2,6,0) go acc x@(UnboxedTupleT _) = passThrough acc x #endif #if MIN_VERSION_template_haskell(2,8,0) go acc x@(PromotedT _) = passThrough acc x go acc x@(PromotedTupleT _) = passThrough acc x go acc x@PromotedConsT = passThrough acc x go acc x@PromotedNilT = passThrough acc x go acc x@StarT = passThrough acc x go acc x@ConstraintT = passThrough acc x go acc x@(LitT _) = passThrough acc x #endif #if MIN_VERSION_template_haskell(2,10,0) go acc x@EqualityT = passThrough acc x #endif #if MIN_VERSION_template_haskell(2,11,0) go acc (InfixT t1 nm t2) = do t1' <- expandSyns t1 t2' <- expandSyns t2 return (acc,InfixT t1' nm t2') go acc (UInfixT t1 nm t2) = do t1' <- expandSyns t1 t2' <- expandSyns t2 return (acc,UInfixT t1' nm t2') go acc (ParensT t) = do (acc',t') <- go acc t return (acc',ParensT t') go acc x@WildCardT = passThrough acc x #endif class SubstTypeVariable a where -- | Capture-free substitution subst :: (Name, Type) -> a -> a instance SubstTypeVariable Type where subst (v, t) = go where go (AppT x y) = AppT (go x) (go y) go s@(ConT _) = s go s@(VarT w) | v == w = t | otherwise = s go ArrowT = ArrowT go ListT = ListT 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 #if MIN_VERSION_template_haskell(2,6,0) go s@(UnboxedTupleT _) = s #endif #if MIN_VERSION_template_haskell(2,8,0) go s@(PromotedT _) = s go s@(PromotedTupleT _) = s go s@PromotedConsT = s go s@PromotedNilT = s go s@StarT = s go s@ConstraintT = s go s@(LitT _) = s #endif #if MIN_VERSION_template_haskell(2,10,0) go s@EqualityT = s #endif #if MIN_VERSION_template_haskell(2,11,0) go (InfixT t1 nm t2) = InfixT (go t1) nm (go t2) go (UInfixT t1 nm t2) = UInfixT (go t1) nm (go t2) go (ParensT t1) = ParensT (go t1) go s@WildCardT = s #endif -- testCapture :: Type -- testCapture = -- let -- n = mkName -- v = VarT . mkName -- in -- substInType (n "x", v "y" `AppT` v "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) && !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: -- -- > type E x = forall y. Either x y -- > -- > ... expandSyns [t| forall y. y -> E y |] -- -- The example as given may actually work correctly without any special capture-avoidance depending -- on how GHC handles the @y@s, but in any case, the input type to expandSyns may be an explicit -- AST using 'mkName' to ensure a collision. -- evade :: Data d => Name -> d -> Name evade n t = let vars :: Set.Set Name vars = everything Set.union (mkQ Set.empty Set.singleton) 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] evades ns t = foldr c [] ns where c n rec = evade n (rec,t) : rec -- evadeTest = let v = mkName "x" -- in -- evade v (AppT (VarT v) (VarT (mkName "fx"))) instance SubstTypeVariable Con where subst (v,t) = go where st = subst (v,t) 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) = commonForallCase (v,t) (vars,cxt,body) #if MIN_VERSION_template_haskell(2,11,0) go c@GadtC{} = errGadt c go c@RecGadtC{} = errGadt c errGadt c = error (packagename++": substInCon currently doesn't support GADT constructors with GHC >= 8 ("++pprint c++")") #endif class HasForallConstruct a where mkForall :: [TyVarBndr] -> Cxt -> a -> a instance HasForallConstruct Type where mkForall = ForallT instance HasForallConstruct Con where mkForall = ForallC commonForallCase :: (SubstTypeVariable a, HasForallConstruct a) => (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, -- 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 | otherwise = let -- prevent capture vars = tyVarBndrGetName <$> bndrs freshes = evades vars t freshTyVarBndrs = zipWith tyVarBndrSetName freshes bndrs substs = zip vars (VarT <$> freshes) doSubsts :: SubstTypeVariable b => b -> b doSubsts x = foldr subst x substs in mkForall freshTyVarBndrs (fmap (subst vt . doSubsts) cxt ) ( (subst vt . doSubsts) body) -- | Capture-free substitution substInType :: (Name,Type) -> Type -> Type substInType = subst -- | Capture-free substitution substInCon :: (Name,Type) -> Con -> Con substInCon = subst th-expand-syns-0.4.0.0/testing/0000755000000000000000000000000012676267743014422 5ustar0000000000000000th-expand-syns-0.4.0.0/testing/Types.hs0000644000000000000000000000151412676267743016063 0ustar0000000000000000{-# 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 () th-expand-syns-0.4.0.0/testing/Util.hs0000644000000000000000000000135212676267743015674 0ustar0000000000000000{-# 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-0.4.0.0/testing/Main.hs0000644000000000000000000000421512676267743015644 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} -- {-# OPTIONS -ddump-splices #-} import Language.Haskell.TH.ExpandSyns import Language.Haskell.TH import Language.Haskell.TH.Syntax import Util import Types main = do putStrLn "Basic test..." $(mkTest [t| forall a. Show a => a -> ForAll [] -> (Int,ApplyToInteger []) |] -- 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] (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 mkTest (forallT'' ["y"] (conT' "E" `appT` varT' "y")) (forallT'' ["y"] expectedExpansion)) putStrLn "Testing that it doesn't crash on type families (expanding them is not supported yet)" $(let t = [t| (DF1 Int, TF1 Int, AT1 Int) |] in mkTest t t) putStrLn "Testing that the args of type family applications are handled" $(mkTest [t| (DF1 Int', TF1 Int', AT1 Int') |] [t| (DF1 Int, TF1 Int, AT1 Int) |]) putStrLn "Higher-kinded synonym" $(mkTest [t| Either' (ListOf Int') (ListOf Char) |] [t| Either [Int] [Char] |]) putStrLn "Nested" $(mkTest [t| Int'' |] [t| Int |])