th-expand-syns 0.4.7.0 → 0.4.8.0
raw patch · 7 files changed
+70/−107 lines, 7 filesdep +th-abstractiondep ~basedep ~template-haskellnew-uploader
Dependencies added: th-abstraction
Dependency ranges changed: base, template-haskell
Files
- LICENSE +1/−1
- Language/Haskell/TH/ExpandSyns.hs +20/−89
- changelog.markdown +5/−0
- testing/Main.hs +4/−4
- testing/Types.hs +1/−1
- testing/Util.hs +14/−5
- th-expand-syns.cabal +25/−7
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2009, Daniel Schüssler+Copyright (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:
Language/Haskell/TH/ExpandSyns.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -Wall -fno-warn-unused-binds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NoMonomorphismRestriction #-} module Language.Haskell.TH.ExpandSyns(-- * Expand synonyms@@ -12,6 +11,7 @@ ,substInCon ,evades,evade) where +import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.ExpandSyns.SemigroupCompat as Sem import Language.Haskell.TH hiding(cxt) import qualified Data.Set as Set@@ -20,6 +20,10 @@ 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@@ -28,65 +32,26 @@ packagename :: String packagename = "th-expand-syns" -#if !MIN_VERSION_template_haskell(2,4,0)-type TyVarBndr = Name-type Pred = Type-#endif--#if MIN_VERSION_template_haskell(2,17,0)-tyVarBndrGetName :: TyVarBndr a -> Name-tyVarBndrGetName (PlainTV n _) = n-tyVarBndrGetName (KindedTV n _ _) = n-#elif MIN_VERSION_template_haskell(2,4,0)-tyVarBndrGetName :: TyVarBndr -> Name-tyVarBndrGetName (PlainTV n) = n-tyVarBndrGetName (KindedTV n _) = n-#else-tyVarBndrGetName = id-#endif--#if MIN_VERSION_template_haskell(2,17,0)-tyVarBndrSetName :: Name -> TyVarBndr a -> TyVarBndr a-tyVarBndrSetName n (PlainTV _ f) = PlainTV n f-tyVarBndrSetName n (KindedTV _ f k) = KindedTV n f k-#elif MIN_VERSION_template_haskell(2,4,0)-tyVarBndrSetName :: Name -> TyVarBndr -> TyVarBndr-tyVarBndrSetName n (PlainTV _) = PlainTV n-tyVarBndrSetName n (KindedTV _ k) = KindedTV n k-#else-tyVarBndrSetName n _ = n-#endif+tyVarBndrSetName :: Name -> TyVarBndr_ flag -> TyVarBndr_ flag+tyVarBndrSetName n = mapTVName (const n) #if MIN_VERSION_template_haskell(2,10,0) -- mapPred is not needed for template-haskell >= 2.10-#elif MIN_VERSION_template_haskell(2,4,0)+#else mapPred :: (Type -> Type) -> Pred -> Pred mapPred f (ClassP n ts) = ClassP n (f <$> ts) mapPred f (EqualP t1 t2) = EqualP (f t1) (f t2)-#else-mapPred = id #endif #if MIN_VERSION_template_haskell(2,10,0) bindPred :: (Type -> Q Type) -> Pred -> Q Pred bindPred = id-#elif MIN_VERSION_template_haskell(2,4,0)+#else bindPred :: (Type -> Q Type) -> Pred -> Q Pred bindPred f (ClassP n ts) = ClassP n <$> mapM f ts-bindPred f (EqualP t1 t2) = EqualP <$> f t1 <*> f t2-#else-bindPred = id+bindPred f (EqualP t1 t2) = (EqualP <$> f t1) `ap` f t2 #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--- data SynonymExpansionSettings = SynonymExpansionSettings { sesWarnTypeFamilies :: Bool@@ -157,7 +122,7 @@ decIsSyn :: SynonymExpansionSettings -> Dec -> Q (Maybe SynInfo) decIsSyn settings = go where- go (TySynD _ vars t) = return (Just (tyVarBndrGetName <$> vars,t))+ go (TySynD _ vars t) = return (Just (tvName <$> vars,t)) #if MIN_VERSION_template_haskell(2,11,0) go (OpenTypeFamilyD (TypeFamilyHead name _ _ _)) = maybeWarnTypeFamily settings name >> no@@ -184,22 +149,18 @@ go (InfixD {}) = no #endif -#if MIN_VERSION_template_haskell(2,4,0) go (PragmaD {}) = no-#endif -- Nothing to expand for data families, so no warning #if MIN_VERSION_template_haskell(2,11,0) go (DataFamilyD {}) = no-#elif MIN_VERSION_template_haskell(2,4,0)+#else go (FamilyD DataFam _ _ _) = no #endif -#if MIN_VERSION_template_haskell(2,4,0) go (DataInstD {}) = no go (NewtypeInstD {}) = no go (TySynInstD {}) = no-#endif #if MIN_VERSION_template_haskell(2,9,0) go (RoleAnnotD {}) = no@@ -225,12 +186,10 @@ no = return Nothing -#if MIN_VERSION_template_haskell(2,4,0) maybeWarnTypeFamily :: SynonymExpansionSettings -> Name -> Q () maybeWarnTypeFamily settings name = when (sesWarnTypeFamilies settings) $ warn ("Type synonym families (and associated type synonyms) are currently not supported (they won't be expanded). Name of unsupported family: "++show name)-#endif @@ -253,15 +212,13 @@ (acc,t') <- go [] t return (foldl applyTypeArg t' acc) -#if MIN_VERSION_template_haskell(2,4,0) expandKindSyns' k =-# if MIN_VERSION_template_haskell(2,8,0)+#if MIN_VERSION_template_haskell(2,8,0) do (acc,k') <- go [] k return (foldl applyTypeArg k' acc)-# else+#else return k -- No kind variables on old versions of GHC-# endif #endif applyTypeArg :: Type -> TypeArg -> Type@@ -336,13 +293,11 @@ 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 kind' <- expandKindSyns' kind return (acc', SigT t' kind')-#endif #if MIN_VERSION_template_haskell(2,6,0) go acc x@(UnboxedTupleT _) = passThrough acc x@@ -435,9 +390,7 @@ go s@(TupleT _) = s -#if MIN_VERSION_template_haskell(2,4,0) go (SigT t1 kind) = SigT (go t1) (subst vt kind)-#endif #if MIN_VERSION_template_haskell(2,6,0) go s@(UnboxedTupleT _) = s@@ -496,12 +449,12 @@ -- (v "x" `AppT` v "y")) -#if MIN_VERSION_template_haskell(2,4,0) && !MIN_VERSION_template_haskell(2,10,0)+#if !MIN_VERSION_template_haskell(2,10,0) instance SubstTypeVariable Pred where subst s = mapPred (subst s) #endif -#if MIN_VERSION_template_haskell(2,4,0) && !MIN_VERSION_template_haskell(2,8,0)+#if !MIN_VERSION_template_haskell(2,8,0) instance SubstTypeVariable Kind where subst _ = id -- No kind variables on old versions of GHC #endif@@ -561,43 +514,21 @@ errGadt c = error (packagename++": substInCon currently doesn't support GADT constructors with GHC >= 8 ("++pprint c++")") #endif --class HasForallConstruct a where-#if MIN_VERSION_template_haskell(2,17,0)- mkForall :: [TyVarBndrSpec] -> Cxt -> a -> a-#else- mkForall :: [TyVarBndr] -> Cxt -> a -> a-#endif--instance HasForallConstruct Type where- mkForall = ForallT--instance HasForallConstruct Con where- mkForall = ForallC--- -- 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@.-#if MIN_VERSION_template_haskell(2,17,0)-commonForallCase :: (Name, Type) -> [TyVarBndr flag]- -> ([(Name, Type)] -> [TyVarBndr flag] -> a)- -> a-#else-commonForallCase :: (Name, Type) -> [TyVarBndr]- -> ([(Name, Type)] -> [TyVarBndr] -> a)+commonForallCase :: (Name, Type) -> [TyVarBndr_ flag]+ -> ([(Name, Type)] -> [TyVarBndr_ flag] -> a) -> a-#endif 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` (tyVarBndrGetName <$> bndrs) = k [vt] bndrs+ | v `elem` (tvName <$> bndrs) = k [vt] bndrs | otherwise = let -- prevent capture- vars = tyVarBndrGetName <$> bndrs+ vars = tvName <$> bndrs freshes = evades vars t freshTyVarBndrs = zipWith tyVarBndrSetName freshes bndrs substs = zip vars (VarT <$> freshes)
changelog.markdown view
@@ -1,3 +1,8 @@+## 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)
testing/Main.hs view
@@ -3,14 +3,14 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-}--- {-# OPTIONS -ddump-splices #-} +import Language.Haskell.TH.Datatype.TyVarBndr import Language.Haskell.TH.ExpandSyns import Language.Haskell.TH-import Language.Haskell.TH.Syntax import Util import Types +main :: IO () main = do putStrLn "Basic test..." $(mkTest [t| forall a. Show a => a -> ForAll [] -> (Int,ApplyToInteger []) |]@@ -31,9 +31,9 @@ -- See comment about 'PlainTV'/'KindedTV' above #if MIN_VERSION_template_haskell(2,10,0)- y_0 = KindedTV (mkName "y_0") StarT+ y_0 = kindedTVSpecified (mkName "y_0") StarT #else- y_0 = PlainTV (mkName "y_0")+ y_0 = plainTVSpecified (mkName "y_0") #endif expectedExpansion =
testing/Types.hs view
@@ -4,7 +4,7 @@ {-# LANGUAGE KindSignatures #-} module Types where -import Language.Haskell.TH+import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax import Util
testing/Util.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE NoMonomorphismRestriction #-}+{-# 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@@ -17,15 +17,24 @@ if (pprint expected'==pprint actual) then [| putStrLn "Ok" |] else [| error "expected /= actual" |] -forallT' xs = forallT ((\x -> PlainTV (mkName x) SpecifiedSpec) `fmap` xs)+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' x = conT . 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.cabal view
@@ -1,30 +1,42 @@ name: th-expand-syns-version: 0.4.7.0+version: 0.4.8.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+maintainer: Ryan Scott <ryan.gl.scott@gmail.com> 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.1+ GHC == 8.8.4+ GHC == 8.10.4+ GHC == 9.0.1 source-repository head type: git- location: git://github.com/DanielSchuessler/th-expand-syns.git+ location: https://github.com/DanielSchuessler/th-expand-syns.git Library- build-depends: base >= 4 && < 5, template-haskell < 2.18, syb, containers- ghc-options:+ build-depends: base >= 4.3 && < 5+ , containers+ , syb+ , th-abstraction >= 0.4 && < 0.5+ , template-haskell >= 2.5 && < 2.18+ ghc-options: -Wall exposed-modules: Language.Haskell.TH.ExpandSyns other-modules: Language.Haskell.TH.ExpandSyns.SemigroupCompat default-language: Haskell2010@@ -34,5 +46,11 @@ hs-source-dirs: testing main-is: Main.hs other-modules: Util, Types- build-depends: base, th-expand-syns, template-haskell+ 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