th-expand-syns-0.4.11.0/0000755000000000000000000000000007346545000013006 5ustar0000000000000000th-expand-syns-0.4.11.0/LICENSE0000644000000000000000000000274707346545000014025 0ustar0000000000000000Copyright (c) 2009, Daniel Schüssler; 2021, Ryan Scott 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.11.0/Language/Haskell/TH/0000755000000000000000000000000007346545000016427 5ustar0000000000000000th-expand-syns-0.4.11.0/Language/Haskell/TH/ExpandSyns.hs0000644000000000000000000002501707346545000021064 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} module Language.Haskell.TH.ExpandSyns(-- * Expand synonyms expandSyns ,expandSynsWith ,SynonymExpansionSettings ,noWarnTypeFamilies -- * Misc utilities ,substInType ,substInCon ,evades,evade) where import Language.Haskell.TH.Datatype import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.ExpandSyns.SemigroupCompat as Sem import Language.Haskell.TH hiding(cxt) import qualified Data.Map as Map import Data.Map (Map) import qualified Data.Set as Set import Data.Generics import Control.Monad import Prelude #if !(MIN_VERSION_base(4,8,0)) import Control.Applicative #endif -- For ghci #ifndef MIN_VERSION_template_haskell #define MIN_VERSION_template_haskell(X,Y,Z) 1 #endif packagename :: String packagename = "th-expand-syns" tyVarBndrSetName :: Name -> TyVarBndr_ flag -> TyVarBndr_ flag tyVarBndrSetName n = mapTVName (const n) data SynonymExpansionSettings = SynonymExpansionSettings { sesWarnTypeFamilies :: Bool } instance Semigroup SynonymExpansionSettings where SynonymExpansionSettings w1 <> SynonymExpansionSettings w2 = SynonymExpansionSettings (w1 && w2) -- | Default settings ('mempty'): -- -- * Warn if type families are encountered. -- -- (The 'mappend' is currently rather useless; the monoid instance is intended for additional settings in the future). instance Monoid SynonymExpansionSettings where mempty = SynonymExpansionSettings { sesWarnTypeFamilies = True } #if !MIN_VERSION_base(4,11,0) -- starting with base-4.11, mappend definitions are redundant; -- at some point `mappend` will be removed from `Monoid` mappend = (Sem.<>) #endif -- | Suppresses the warning that type families are unsupported. noWarnTypeFamilies :: SynonymExpansionSettings noWarnTypeFamilies = mempty { sesWarnTypeFamilies = False } warn :: String -> Q () warn msg = #if MIN_VERSION_template_haskell(2,8,0) reportWarning #else report False #endif (packagename ++": WARNING: "++msg) warnIfNameIsTypeFamily :: Name -> Q () warnIfNameIsTypeFamily n = do i <- reify n case i of ClassI {} -> return () ClassOpI {} -> return () TyConI d -> warnIfDecIsTypeFamily d #if MIN_VERSION_template_haskell(2,7,0) FamilyI d _ -> warnIfDecIsTypeFamily d -- Called for warnings #endif PrimTyConI {} -> return () DataConI {} -> return () VarI {} -> return () TyVarI {} -> return () #if MIN_VERSION_template_haskell(2,12,0) PatSynI {} -> return () #endif warnIfDecIsTypeFamily :: Dec -> Q () warnIfDecIsTypeFamily = go where go (TySynD {}) = return () #if MIN_VERSION_template_haskell(2,11,0) go (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) = maybeWarnTypeFamily name go (ClosedTypeFamilyD (TypeFamilyHead name _ _ _) _) = maybeWarnTypeFamily name #else #if MIN_VERSION_template_haskell(2,9,0) go (ClosedTypeFamilyD name _ _ _) = maybeWarnTypeFamily name #endif go (FamilyD TypeFam name _ _) = maybeWarnTypeFamily name #endif go (FunD {}) = return () go (ValD {}) = return () go (DataD {}) = return () go (NewtypeD {}) = return () go (ClassD {}) = return () go (InstanceD {}) = return () go (SigD {}) = return () go (ForeignD {}) = return () #if MIN_VERSION_template_haskell(2,8,0) go (InfixD {}) = return () #endif go (PragmaD {}) = return () -- Nothing to expand for data families, so no warning #if MIN_VERSION_template_haskell(2,11,0) go (DataFamilyD {}) = return () #else go (FamilyD DataFam _ _ _) = return () #endif go (DataInstD {}) = return () go (NewtypeInstD {}) = return () go (TySynInstD {}) = return () #if MIN_VERSION_template_haskell(2,9,0) go (RoleAnnotD {}) = return () #endif #if MIN_VERSION_template_haskell(2,10,0) go (StandaloneDerivD {}) = return () go (DefaultSigD {}) = return () #endif #if MIN_VERSION_template_haskell(2,12,0) go (PatSynD {}) = return () go (PatSynSigD {}) = return () #endif #if MIN_VERSION_template_haskell(2,15,0) go (ImplicitParamBindD {}) = return () #endif #if MIN_VERSION_template_haskell(2,16,0) go (KiSigD {}) = return () #endif #if MIN_VERSION_template_haskell(2,19,0) go (DefaultD {}) = return () #endif #if MIN_VERSION_template_haskell(2,20,0) go (TypeDataD {}) = return () #endif warnTypeFamiliesInType :: Type -> Q () warnTypeFamiliesInType = go where go :: Type -> Q () go (ConT n) = warnIfNameIsTypeFamily n go (AppT t1 t2) = go t1 >> go t2 go (SigT t k) = go t >> go_kind k go ListT{} = return () go ArrowT{} = return () go VarT{} = return () go TupleT{} = return () go (ForallT tvbs ctxt body) = do mapM_ (go_kind . tvKind) tvbs mapM_ go_pred ctxt go body #if MIN_VERSION_template_haskell(2,6,0) go UnboxedTupleT{} = return () #endif #if MIN_VERSION_template_haskell(2,8,0) go PromotedT{} = return () go PromotedTupleT{} = return () go PromotedConsT{} = return () go PromotedNilT{} = return () go StarT{} = return () go ConstraintT{} = return () go LitT{} = return () #endif #if MIN_VERSION_template_haskell(2,10,0) go EqualityT{} = return () #endif #if MIN_VERSION_template_haskell(2,11,0) go (InfixT t1 n t2) = do warnIfNameIsTypeFamily n go t1 go t2 go (UInfixT t1 n t2) = do warnIfNameIsTypeFamily n go t1 go t2 go (ParensT t) = go t go WildCardT{} = return () #endif #if MIN_VERSION_template_haskell(2,12,0) go UnboxedSumT{} = return () #endif #if MIN_VERSION_template_haskell(2,15,0) go (AppKindT t k) = go t >> go_kind k go (ImplicitParamT _ t) = go t #endif #if MIN_VERSION_template_haskell(2,16,0) go (ForallVisT tvbs body) = do mapM_ (go_kind . tvKind) tvbs go body #endif #if MIN_VERSION_template_haskell(2,17,0) go MulArrowT{} = return () #endif #if MIN_VERSION_template_haskell(2,19,0) go (PromotedInfixT t1 n t2) = do warnIfNameIsTypeFamily n go t1 go t2 go (PromotedUInfixT t1 n t2) = do warnIfNameIsTypeFamily n go t1 go t2 #endif go_kind :: Kind -> Q () #if MIN_VERSION_template_haskell(2,8,0) go_kind = go #else go_kind _ = return () #endif go_pred :: Pred -> Q () #if MIN_VERSION_template_haskell(2,10,0) go_pred = go #else go_pred (ClassP _ ts) = mapM_ go ts go_pred (EqualP t1 t2) = go t1 >> go t2 #endif maybeWarnTypeFamily :: Name -> Q () maybeWarnTypeFamily name = warn ("Type synonym families (and associated type synonyms) are currently not supported (they won't be expanded). Name of unsupported family: "++show name) -- | Calls 'expandSynsWith' with the default settings. expandSyns :: Type -> Q Type expandSyns = expandSynsWith mempty -- | Expands all type synonyms in the given type. Type families currently won't be expanded (but will be passed through). expandSynsWith :: SynonymExpansionSettings -> Type -> Q Type expandSynsWith settings = expandSyns' where expandSyns' x = do when (sesWarnTypeFamilies settings) $ warnTypeFamiliesInType x resolveTypeSynonyms x -- | 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"))) -- | Capture-free substitution substInType :: (Name,Type) -> Type -> Type substInType vt = applySubstitution (Map.fromList [vt]) -- | Capture-free substitution substInCon :: (Name,Type) -> Con -> Con substInCon vt = go where vtSubst = Map.fromList [vt] st = applySubstitution vtSubst 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 vt vars $ \vts' vars' -> ForallC (map (mapTVKind (applySubstitution vts')) vars') (applySubstitution vts' cxt) (Map.foldrWithKey (\v t -> substInCon (v, t)) body vts') #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 -- Apply a substitution to something underneath a @forall@. The continuation -- argument provides new substitutions and fresh type variable binders to avoid -- the outer substitution from capturing the thing underneath the @forall@. commonForallCase :: (Name, Type) -> [TyVarBndr_ flag] -> (Map Name Type -> [TyVarBndr_ flag] -> a) -> a commonForallCase vt@(v,t) bndrs k -- 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` (tvName <$> bndrs) = k (Map.fromList [vt]) bndrs | otherwise = let -- prevent capture vars = tvName <$> bndrs freshes = evades vars t freshTyVarBndrs = zipWith tyVarBndrSetName freshes bndrs substs = zip vars (VarT <$> freshes) in k (Map.fromList (vt:substs)) freshTyVarBndrs th-expand-syns-0.4.11.0/Language/Haskell/TH/ExpandSyns/0000755000000000000000000000000007346545000020523 5ustar0000000000000000th-expand-syns-0.4.11.0/Language/Haskell/TH/ExpandSyns/SemigroupCompat.hs0000644000000000000000000000043107346545000024173 0ustar0000000000000000{-# LANGUAGE CPP #-} module Language.Haskell.TH.ExpandSyns.SemigroupCompat(Semigroup(..), Monoid(..)) where #if MIN_VERSION_base(4,9,0) import Data.Semigroup #else import Data.Monoid(Monoid(..)) import Prelude infixr 6 <> class Semigroup a where (<>) :: a -> a -> a #endif th-expand-syns-0.4.11.0/Setup.lhs0000644000000000000000000000011407346545000014612 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain th-expand-syns-0.4.11.0/changelog.markdown0000644000000000000000000000444407346545000016507 0ustar0000000000000000## 0.4.11.0 [2023.01.31] * Support `TypeDataD` when building with `template-haskell-2.20.0.0` (GHC 9.6) or later. ## 0.4.10.0 [2022.07.23] * Support `DefaultD`, `PromotedInfixT`, and `PromotedUInfixT` when building with `template-haskell-2.19.0.0` (GHC 9.4) or later. ## 0.4.9.0 [2021.08.30] * Consolidate the type-synonym expansion functionality with `th-abstraction`, which also provides the ability to expand type synonyms. After this change, the `th-expand-syns` library is mostly a small shim on top of `th-abstraction`. The only additional pieces of functionality that `th-expand-syns` which aren't currently available in `th-abstraction` are: * `th-expand-syns`' `expandSyns{With}` functions will warn that they cannot expand type families (if the `SynonymExpansionSettings` are configured to check for this). By contrast, `th-abstraction`'s `applySubstitution` function will silently ignore type families. * `th-expand-syns` provides a `substInCon` function which allows substitution into `Con`s. * `th-expand-syns` provides `evade{s}` functions which support type variable `Name` freshening that calculating the free variables in any type that provides an instance of `Data`. ## 0.4.8.0 [2021.03.12] * Make the test suite compile with GHC 9.0 or later. * Drop support for pre-7.0 versions of GHC. ## 0.4.7.0 * Support GHC 9.0 / template-haskell-2.17 (Thanks to @mgsloan) ## 0.4.5.0 * Support GHC 8.8 / template-haskell-2.15 (Thanks to Ryan Scott) * Support GHC 8.6 / template-haskell-2.14 (Thanks to Chaitanya Koparkar) ## 0.4.4.0 * Made `SynonymExpansionSettings` an instance of `Semigroup` (fixes build with GHC 8.4.1 alpha). ## 0.4.3.0 * Added support for GHC 8.2.1 / template-haskell-2.12 (Thanks to Ryan Scott) ## 0.4.2.0 * Eliminated warnings about unrecognized results of 'reify'. ## 0.4.1.0 * Added a setting for suppressing warnings about type families. ## 0.4.0.0 * Fixed build with GHC 8 / template-haskell-2.11 (Thanks to Christiaan Baaij) Note: `substInCon` doesn't support GADT constructors 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.11.0/testing/0000755000000000000000000000000007346545000014463 5ustar0000000000000000th-expand-syns-0.4.11.0/testing/Main.hs0000644000000000000000000000506307346545000015707 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.ExpandSyns import Language.Haskell.TH import Util import Types main :: IO () 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 = kindedTVSpecified (mkName "y_0") StarT #else y_0 = plainTVSpecified (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 |]) #if MIN_VERSION_template_haskell(2,8,0) putStrLn "Synonyms in kinds" $(mkTest (sigT (conT ''Int) (ConT ''Id `AppT` StarT)) (sigT (conT ''Int) StarT)) #endif $(do reportWarning "No warning about type families should appear after this line." -- TODO: Automate this test with a custom Quasi instance? _ <- expandSynsWith noWarnTypeFamilies =<< [t| (DF1 Int', TF1 Int', AT1 Int') |] [| return () |]) th-expand-syns-0.4.11.0/testing/Types.hs0000644000000000000000000000153607346545000016130 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE KindSignatures #-} module Types where import Language.Haskell.TH.Lib 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 Id a = a -- 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.11.0/testing/Util.hs0000644000000000000000000000220107346545000015727 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} module Util where import Language.Haskell.TH import Language.Haskell.TH.Datatype.TyVarBndr 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' :: [String] -> Q Cxt -> Q Type -> Q Type forallT' xs = forallT ((plainTVSpecified . mkName) `fmap` xs) forallT'' :: [String] -> Q Type -> Q Type forallT'' xs = forallT' xs (cxt []) varT' :: String -> Q Type varT' = varT . mkName conT' :: String -> Q Type conT' = conT . mkName (-->) :: Q Type -> Q Type -> Q Type x --> y = (arrowT `appT` x) `appT` y infixr 5 --> #if !MIN_VERSION_template_haskell(2,8,0) reportWarning :: String -> Q () reportWarning = report False #endif th-expand-syns-0.4.11.0/th-expand-syns.cabal0000644000000000000000000000412207346545000016653 0ustar0000000000000000name: th-expand-syns version: 0.4.11.0 synopsis: Expands type synonyms in Template Haskell ASTs description: Expands type synonyms in Template Haskell ASTs. . As of version @0.4.9.0@, this library is a small shim on top of the @applySubstitution@/@resolveTypeSynonyms@ functions from @th-abstraction@, so you may want to consider using @th-abstraction@ instead. category: Template Haskell license: BSD3 license-file: LICENSE author: Daniel Schüssler maintainer: Ryan Scott cabal-version: >= 1.10 build-type: Simple extra-source-files: changelog.markdown homepage: https://github.com/DanielSchuessler/th-expand-syns tested-with: GHC == 7.0.4 GHC == 7.2.2 GHC == 7.4.2 GHC == 7.6.3 GHC == 7.8.4 GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 GHC == 8.4.4 GHC == 8.6.5 GHC == 8.8.4 GHC == 8.10.7 GHC == 9.0.2 GHC == 9.2.2 source-repository head type: git location: https://github.com/DanielSchuessler/th-expand-syns.git Library build-depends: base >= 4.3 && < 5 , containers , syb , th-abstraction >= 0.4.3 && < 0.5 , template-haskell >= 2.5 && < 2.21 ghc-options: -Wall exposed-modules: Language.Haskell.TH.ExpandSyns other-modules: Language.Haskell.TH.ExpandSyns.SemigroupCompat default-language: Haskell2010 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 , template-haskell , th-abstraction , th-expand-syns ghc-options: -Wall if impl(ghc >= 8.6) ghc-options: -Wno-star-is-type default-language: Haskell2010