Date: Sunday, January 9, 2022 @ 15:00:45 Author: felixonmars Revision: 1098273
upgpkg: haskell-th-extras 0.0.0.5-1: rebuild with th-extras 0.0.0.5 Modified: haskell-th-extras/trunk/PKGBUILD Deleted: haskell-th-extras/trunk/ghc9.patch ------------+ PKGBUILD | 14 ghc9.patch | 876 ----------------------------------------------------------- 2 files changed, 4 insertions(+), 886 deletions(-) Modified: PKGBUILD =================================================================== --- PKGBUILD 2022-01-09 14:25:21 UTC (rev 1098272) +++ PKGBUILD 2022-01-09 15:00:45 UTC (rev 1098273) @@ -2,8 +2,8 @@ _hkgname=th-extras pkgname=haskell-th-extras -pkgver=0.0.0.4 -pkgrel=69 +pkgver=0.0.0.5 +pkgrel=1 pkgdesc="A grab bag of functions for use with Template Haskell" url="https://github.com/mokus0/th-extras"; license=("custom:PublicDomain") @@ -10,15 +10,9 @@ arch=('x86_64') depends=('ghc-libs' 'haskell-syb' 'haskell-th-abstraction') makedepends=('ghc') -source=("https://hackage.haskell.org/packages/archive/$_hkgname/$pkgver/$_hkgname-$pkgver.tar.gz"; - ghc9.patch) -sha256sums=('8feff450aaf28ec4f08c45a5656c62879861a8e7f45591cb367d5351ddc3fbed' - '882392e14f1badac93e3796d7c82ae6688a97ad5fdd6d914b6e4b2f070782712') +source=("https://hackage.haskell.org/packages/archive/$_hkgname/$pkgver/$_hkgname-$pkgver.tar.gz";) +sha256sums=('355e5bc17951e3bfe569e7f76159ca83a36be6ab559a18fc9d4bd9de9be2ee0e') -prepare() { - patch -d $_hkgname-$pkgver -p1 < ghc9.patch -} - build() { cd $_hkgname-$pkgver Deleted: ghc9.patch =================================================================== --- ghc9.patch 2022-01-09 14:25:21 UTC (rev 1098272) +++ ghc9.patch 2022-01-09 15:00:45 UTC (rev 1098273) @@ -1,876 +0,0 @@ -From 51b36f3a9cb5691a9c2cc6ed5d12d0aa65873f66 Mon Sep 17 00:00:00 2001 -From: Edward Betts <[email protected]> -Date: Fri, 1 Sep 2017 18:39:57 +0100 -Subject: [PATCH 02/14] correct spelling mistake - ---- - src/Language/Haskell/TH/Extras.hs | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index 9da19e3..85b2229 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -116,7 +116,7 @@ genericalizeDecs :: [Dec] -> [Dec] - genericalizeDecs decs = everywhere (mkT fixName) decs - where - -- get all names bound in the decs and make them generic -- -- at every occurence in decs. -+ -- at every occurrence in decs. - names = decs >>= namesBoundInDec - genericalizedNames = [ (n, genericalizeName n) | n <- names] - fixName = replace (`lookup` genericalizedNames) --- -2.32.0 - - -From 798ee05249aa79e86b56c7ec33139684e6271b2b Mon Sep 17 00:00:00 2001 -From: Ali Abrar <[email protected]> -Date: Thu, 9 May 2019 17:35:03 -0400 -Subject: [PATCH 03/14] Add a few functions for extracting information from - types and constructors (e.g., arity) - ---- - src/Language/Haskell/TH/Extras.hs | 111 +++++++++++++++++++++++++++++- - th-extras.cabal | 1 + - 2 files changed, 111 insertions(+), 1 deletion(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index 85b2229..1cd5d1f 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -1,9 +1,10 @@ --{-# LANGUAGE CPP, TemplateHaskell #-} -+{-# LANGUAGE CPP, LambdaCase, TemplateHaskell #-} - module Language.Haskell.TH.Extras where - - import Control.Monad - import Data.Generics - import Data.Maybe -+import qualified Data.Set as Set - import Language.Haskell.TH - import Language.Haskell.TH.Syntax - -@@ -154,3 +155,111 @@ occursInType var ty = case ty of - #endif - _ -> False - -+-- | Assuming that we're building an instance of the form C (T v_1 ... v_(n-1)) for some GADT T, this function -+-- takes a list of the variables v_1 ... v_(n-1) used in the instance head, as well as the result type of some data -+-- constructor, say T x_1 ... x_(n-1) x_n, as well as the type t of some argument to it, and substitutes any of -+-- x_i (1 <= i <= n-1) occurring in t for the corresponding v_i, taking care to avoid name capture by foralls in t. -+substVarsWith -+ :: [Name] -- Names of variables used in the instance head in argument order -+ -> Type -- Result type of constructor -+ -> Type -- Type of argument to the constructor -+ -> Type -- Type of argument with variables substituted for instance head variables. -+substVarsWith topVars resultType argType = subst Set.empty argType -+ where -+ topVars' = reverse topVars -+ AppT resultType' _indexType = resultType -+ subst bs = \case -+ ForallT bndrs cxt t -> -+ let bs' = Set.union bs (Set.fromList (map tyVarBndrName bndrs)) -+ in ForallT bndrs (map (subst bs') cxt) (subst bs' t) -+ AppT f x -> AppT (subst bs f) (subst bs x) -+ SigT t k -> SigT (subst bs t) k -+ VarT v -> if Set.member v bs -+ then VarT v -+ else VarT (findVar v topVars' resultType') -+ InfixT t1 x t2 -> InfixT (subst bs t1) x (subst bs t2) -+ UInfixT t1 x t2 -> UInfixT (subst bs t1) x (subst bs t2) -+ ParensT t -> ParensT (subst bs t) -+ -- The following cases could all be covered by an "x -> x" case, but I'd rather know if new cases -+ -- need to be handled specially in future versions of Template Haskell. -+ PromotedT n -> PromotedT n -+ ConT n -> ConT n -+ TupleT k -> TupleT k -+ UnboxedTupleT k -> UnboxedTupleT k -+ UnboxedSumT k -> UnboxedSumT k -+ ArrowT -> ArrowT -+ EqualityT -> EqualityT -+ ListT -> ListT -+ PromotedTupleT k -> PromotedTupleT k -+ PromotedNilT -> PromotedNilT -+ PromotedConsT -> PromotedConsT -+ StarT -> StarT -+ ConstraintT -> ConstraintT -+ LitT l -> LitT l -+ WildCardT -> WildCardT -+ findVar v (tv:_) (AppT _ (VarT v')) | v == v' = tv -+ findVar v (_:tvs) (AppT t (VarT _)) = findVar v tvs t -+ findVar v _ _ = error $ "substVarsWith: couldn't look up variable substitution for " <> show v -+ <> " with topVars: " <> show topVars <> " resultType: " <> show resultType <> " argType: " <> show argType -+ -+-- | Determine the 'Name' being bound by a 'TyVarBndr'. -+tyVarBndrName :: TyVarBndr -> Name -+tyVarBndrName = \case -+ PlainTV n -> n -+ KindedTV n _ -> n -+ -+-- | Determine the arity of a kind. -+kindArity :: Kind -> Int -+kindArity = \case -+ ForallT _ _ t -> kindArity t -+ AppT (AppT ArrowT _) t -> 1 + kindArity t -+ SigT t _ -> kindArity t -+ ParensT t -> kindArity t -+ _ -> 0 -+ -+-- | Given the name of a type constructor, determine its full arity -+tyConArity :: Name -> Q Int -+tyConArity n = do -+ (ts, ka) <- tyConArity' n -+ return (length ts + ka) -+ -+-- | Given the name of a type constructor, determine a list of type variables bound as parameters by -+-- its declaration, and the arity of the kind of type being defined (i.e. how many more arguments would -+-- need to be supplied in addition to the bound parameters in order to obtain an ordinary type of kind *). -+-- If the supplied 'Name' is anything other than a data or newtype, produces an error. -+tyConArity' :: Name -> Q ([TyVarBndr], Int) -+tyConArity' n = reify n >>= return . \case -+ TyConI (DataD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) -+ TyConI (NewtypeD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) -+ _ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " <> show n -+ -+-- | Determine the constructors bound by a data or newtype declaration. Errors out if supplied with another -+-- sort of declaration. -+decCons :: Dec -> [Con] -+decCons = \case -+ DataD _ _ _ _ cs _ -> cs -+ NewtypeD _ _ _ _ c _ -> [c] -+ _ -> error "decCons: Declaration found was not a data or newtype declaration." -+ -+-- | Determines the name of a data constructor. It's an error if the 'Con' binds more than one name (which -+-- happens in the case where you use GADT syntax, and give multiple data constructor names separated by commas -+-- in a type signature in the where clause). -+conName :: Con -> Name -+conName = \case -+ NormalC n _ -> n -+ RecC n _ -> n -+ InfixC _ n _ -> n -+ ForallC _ _ c' -> conName c' -+ GadtC [n] _ _ -> n -+ RecGadtC [n] _ _ -> n -+ _ -> error "conName: GADT constructors with multiple names not yet supported" -+ -+-- | Determine the arity of a data constructor. -+conArity :: Con -> Int -+conArity = \case -+ NormalC _ ts -> length ts -+ RecC _ ts -> length ts -+ InfixC _ _ _ -> 2 -+ ForallC _ _ c' -> conArity c' -+ GadtC _ ts _ -> length ts -+ RecGadtC _ ts _ -> length ts -diff --git a/th-extras.cabal b/th-extras.cabal -index dcc4996..5031a5d 100644 ---- a/th-extras.cabal -+++ b/th-extras.cabal -@@ -33,6 +33,7 @@ Library - hs-source-dirs: src - exposed-modules: Language.Haskell.TH.Extras - build-depends: base >= 3 && < 5, -+ containers, - template-haskell - - if flag(base4) --- -2.32.0 - - -From 100ac804f116aed56fec968603aa6d25c84181ce Mon Sep 17 00:00:00 2001 -From: Ali Abrar <[email protected]> -Date: Thu, 9 May 2019 18:39:13 -0400 -Subject: [PATCH 04/14] Eliminate use of LambdaCase - ---- - src/Language/Haskell/TH/Extras.hs | 24 +++++++++++++----------- - 1 file changed, 13 insertions(+), 11 deletions(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index 1cd5d1f..29ef34d 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -1,4 +1,4 @@ --{-# LANGUAGE CPP, LambdaCase, TemplateHaskell #-} -+{-# LANGUAGE CPP, TemplateHaskell #-} - module Language.Haskell.TH.Extras where - - import Control.Monad -@@ -168,7 +168,7 @@ substVarsWith topVars resultType argType = subst Set.empty argType - where - topVars' = reverse topVars - AppT resultType' _indexType = resultType -- subst bs = \case -+ subst bs ty = case ty of - ForallT bndrs cxt t -> - let bs' = Set.union bs (Set.fromList (map tyVarBndrName bndrs)) - in ForallT bndrs (map (subst bs') cxt) (subst bs' t) -@@ -204,13 +204,13 @@ substVarsWith topVars resultType argType = subst Set.empty argType - - -- | Determine the 'Name' being bound by a 'TyVarBndr'. - tyVarBndrName :: TyVarBndr -> Name --tyVarBndrName = \case -+tyVarBndrName tvb = case tvb of - PlainTV n -> n - KindedTV n _ -> n - - -- | Determine the arity of a kind. - kindArity :: Kind -> Int --kindArity = \case -+kindArity k = case k of - ForallT _ _ t -> kindArity t - AppT (AppT ArrowT _) t -> 1 + kindArity t - SigT t _ -> kindArity t -@@ -228,15 +228,17 @@ tyConArity n = do - -- need to be supplied in addition to the bound parameters in order to obtain an ordinary type of kind *). - -- If the supplied 'Name' is anything other than a data or newtype, produces an error. - tyConArity' :: Name -> Q ([TyVarBndr], Int) --tyConArity' n = reify n >>= return . \case -- TyConI (DataD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) -- TyConI (NewtypeD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) -- _ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " <> show n -+tyConArity' n = do -+ r <- reify n -+ return $ case r of -+ TyConI (DataD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) -+ TyConI (NewtypeD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) -+ _ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " <> show n - - -- | Determine the constructors bound by a data or newtype declaration. Errors out if supplied with another - -- sort of declaration. - decCons :: Dec -> [Con] --decCons = \case -+decCons d = case d of - DataD _ _ _ _ cs _ -> cs - NewtypeD _ _ _ _ c _ -> [c] - _ -> error "decCons: Declaration found was not a data or newtype declaration." -@@ -245,7 +247,7 @@ decCons = \case - -- happens in the case where you use GADT syntax, and give multiple data constructor names separated by commas - -- in a type signature in the where clause). - conName :: Con -> Name --conName = \case -+conName c = case c of - NormalC n _ -> n - RecC n _ -> n - InfixC _ n _ -> n -@@ -256,7 +258,7 @@ conName = \case - - -- | Determine the arity of a data constructor. - conArity :: Con -> Int --conArity = \case -+conArity c = case c of - NormalC _ ts -> length ts - RecC _ ts -> length ts - InfixC _ _ _ -> 2 --- -2.32.0 - - -From 5926406ce43ac8770ed69cfd839dd5f3c503fc61 Mon Sep 17 00:00:00 2001 -From: Ali Abrar <[email protected]> -Date: Fri, 10 May 2019 05:32:27 -0400 -Subject: [PATCH 05/14] Make substVarsWith compatible with older - template-haskell versions - ---- - src/Language/Haskell/TH/Extras.hs | 38 ++++++++++++++++++++----------- - 1 file changed, 25 insertions(+), 13 deletions(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index 29ef34d..c575ed4 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -4,6 +4,7 @@ module Language.Haskell.TH.Extras where - import Control.Monad - import Data.Generics - import Data.Maybe -+import Data.Semigroup ((<>)) - import qualified Data.Set as Set - import Language.Haskell.TH - import Language.Haskell.TH.Syntax -@@ -169,6 +170,9 @@ substVarsWith topVars resultType argType = subst Set.empty argType - topVars' = reverse topVars - AppT resultType' _indexType = resultType - subst bs ty = case ty of -+ -- Several of the following cases could all be covered by an "x -> x" case, but -+ -- I'd rather know if new cases need to be handled specially in future versions -+ -- of Template Haskell. - ForallT bndrs cxt t -> - let bs' = Set.union bs (Set.fromList (map tyVarBndrName bndrs)) - in ForallT bndrs (map (subst bs') cxt) (subst bs' t) -@@ -177,26 +181,30 @@ substVarsWith topVars resultType argType = subst Set.empty argType - VarT v -> if Set.member v bs - then VarT v - else VarT (findVar v topVars' resultType') -- InfixT t1 x t2 -> InfixT (subst bs t1) x (subst bs t2) -- UInfixT t1 x t2 -> UInfixT (subst bs t1) x (subst bs t2) -- ParensT t -> ParensT (subst bs t) -- -- The following cases could all be covered by an "x -> x" case, but I'd rather know if new cases -- -- need to be handled specially in future versions of Template Haskell. -- PromotedT n -> PromotedT n - ConT n -> ConT n - TupleT k -> TupleT k - UnboxedTupleT k -> UnboxedTupleT k -- UnboxedSumT k -> UnboxedSumT k - ArrowT -> ArrowT -- EqualityT -> EqualityT - ListT -> ListT -- PromotedTupleT k -> PromotedTupleT k -- PromotedNilT -> PromotedNilT -- PromotedConsT -> PromotedConsT -- StarT -> StarT -+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 -+ InfixT t1 x t2 -> InfixT (subst bs t1) x (subst bs t2) -+ ParensT t -> ParensT (subst bs t) -+ UInfixT t1 x t2 -> UInfixT (subst bs t1) x (subst bs t2) -+ UnboxedSumT k -> UnboxedSumT k -+ WildCardT -> WildCardT -+#endif -+#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 784 -+ EqualityT -> EqualityT -+#endif -+#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 763 - ConstraintT -> ConstraintT - LitT l -> LitT l -- WildCardT -> WildCardT -+ PromotedConsT -> PromotedConsT -+ PromotedNilT -> PromotedNilT -+ PromotedT n -> PromotedT n -+ PromotedTupleT k -> PromotedTupleT k -+ StarT -> StarT -+#endif - findVar v (tv:_) (AppT _ (VarT v')) | v == v' = tv - findVar v (_:tvs) (AppT t (VarT _)) = findVar v tvs t - findVar v _ _ = error $ "substVarsWith: couldn't look up variable substitution for " <> show v -@@ -252,8 +260,10 @@ conName c = case c of - RecC n _ -> n - InfixC _ n _ -> n - ForallC _ _ c' -> conName c' -+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 - GadtC [n] _ _ -> n - RecGadtC [n] _ _ -> n -+#endif - _ -> error "conName: GADT constructors with multiple names not yet supported" - - -- | Determine the arity of a data constructor. -@@ -263,5 +273,7 @@ conArity c = case c of - RecC _ ts -> length ts - InfixC _ _ _ -> 2 - ForallC _ _ c' -> conArity c' -+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 - GadtC _ ts _ -> length ts - RecGadtC _ ts _ -> length ts -+#endif --- -2.32.0 - - -From 9faf814edc5a80c3a96c97d77966a95e07f6e0b3 Mon Sep 17 00:00:00 2001 -From: Ali Abrar <[email protected]> -Date: Fri, 10 May 2019 05:38:13 -0400 -Subject: [PATCH 06/14] Replace Semigroup with Monoid for backward - compatibility - ---- - src/Language/Haskell/TH/Extras.hs | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index c575ed4..892050b 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -4,7 +4,7 @@ module Language.Haskell.TH.Extras where - import Control.Monad - import Data.Generics - import Data.Maybe --import Data.Semigroup ((<>)) -+import Data.Monoid ((<>)) - import qualified Data.Set as Set - import Language.Haskell.TH - import Language.Haskell.TH.Syntax --- -2.32.0 - - -From f5ad58b8b2999316f03e9a0b4a12693bb45ea766 Mon Sep 17 00:00:00 2001 -From: Ali Abrar <[email protected]> -Date: Fri, 10 May 2019 05:45:24 -0400 -Subject: [PATCH 07/14] Fix kindArity for older TH; Don't use Monoid for string - concat - ---- - src/Language/Haskell/TH/Extras.hs | 9 +++++---- - 1 file changed, 5 insertions(+), 4 deletions(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index 892050b..74ade24 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -4,7 +4,6 @@ module Language.Haskell.TH.Extras where - import Control.Monad - import Data.Generics - import Data.Maybe --import Data.Monoid ((<>)) - import qualified Data.Set as Set - import Language.Haskell.TH - import Language.Haskell.TH.Syntax -@@ -207,8 +206,8 @@ substVarsWith topVars resultType argType = subst Set.empty argType - #endif - findVar v (tv:_) (AppT _ (VarT v')) | v == v' = tv - findVar v (_:tvs) (AppT t (VarT _)) = findVar v tvs t -- findVar v _ _ = error $ "substVarsWith: couldn't look up variable substitution for " <> show v -- <> " with topVars: " <> show topVars <> " resultType: " <> show resultType <> " argType: " <> show argType -+ findVar v _ _ = error $ "substVarsWith: couldn't look up variable substitution for " ++ show v -+ ++ " with topVars: " ++ show topVars ++ " resultType: " ++ show resultType ++ " argType: " ++ show argType - - -- | Determine the 'Name' being bound by a 'TyVarBndr'. - tyVarBndrName :: TyVarBndr -> Name -@@ -222,7 +221,9 @@ kindArity k = case k of - ForallT _ _ t -> kindArity t - AppT (AppT ArrowT _) t -> 1 + kindArity t - SigT t _ -> kindArity t -+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 - ParensT t -> kindArity t -+#endif - _ -> 0 - - -- | Given the name of a type constructor, determine its full arity -@@ -241,7 +242,7 @@ tyConArity' n = do - return $ case r of - TyConI (DataD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) - TyConI (NewtypeD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) -- _ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " <> show n -+ _ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " ++ show n - - -- | Determine the constructors bound by a data or newtype declaration. Errors out if supplied with another - -- sort of declaration. --- -2.32.0 - - -From 776e4ea798202c4d8018ffbe41acf06fba352504 Mon Sep 17 00:00:00 2001 -From: Ali Abrar <[email protected]> -Date: Fri, 10 May 2019 06:02:32 -0400 -Subject: [PATCH 09/14] Fix decCons and conArity for older TH. Remove conName - (use nameOfCon instead) - ---- - .travis.yml | 6 +++--- - src/Language/Haskell/TH/Extras.hs | 33 +++++++++++++++---------------- - 2 files changed, 19 insertions(+), 20 deletions(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index 74ade24..2241d62 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -6,7 +6,6 @@ import Data.Generics - import Data.Maybe - import qualified Data.Set as Set - import Language.Haskell.TH --import Language.Haskell.TH.Syntax - - intIs64 :: Bool - intIs64 = toInteger (maxBound :: Int) > 2^32 -@@ -19,6 +18,9 @@ composeExprs [] = [| id |] - composeExprs [f] = f - composeExprs (f:fs) = [| $f . $(composeExprs fs) |] - -+-- | Determines the name of a data constructor. It's an error if the 'Con' binds more than one name (which -+-- happens in the case where you use GADT syntax, and give multiple data constructor names separated by commas -+-- in a type signature in the where clause). - nameOfCon :: Con -> Name - nameOfCon (NormalC name _) = name - nameOfCon (RecC name _) = name -@@ -182,7 +184,6 @@ substVarsWith topVars resultType argType = subst Set.empty argType - else VarT (findVar v topVars' resultType') - ConT n -> ConT n - TupleT k -> TupleT k -- UnboxedTupleT k -> UnboxedTupleT k - ArrowT -> ArrowT - ListT -> ListT - #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 -@@ -203,6 +204,9 @@ substVarsWith topVars resultType argType = subst Set.empty argType - PromotedT n -> PromotedT n - PromotedTupleT k -> PromotedTupleT k - StarT -> StarT -+#endif -+#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 704 -+ UnboxedTupleT k -> UnboxedTupleT k - #endif - findVar v (tv:_) (AppT _ (VarT v')) | v == v' = tv - findVar v (_:tvs) (AppT t (VarT _)) = findVar v tvs t -@@ -240,32 +244,27 @@ tyConArity' :: Name -> Q ([TyVarBndr], Int) - tyConArity' n = do - r <- reify n - return $ case r of -+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 - TyConI (DataD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) - TyConI (NewtypeD _ _ ts mk _ _) -> (ts, fromMaybe 0 (fmap kindArity mk)) -+#else -+ TyConI (DataD _ _ ts _ _) -> (ts, 0) -+ TyConI (NewtypeD _ _ ts _ _) -> (ts, 0) -+#endif - _ -> error $ "tyConArity': Supplied name reified to something other than a data declaration: " ++ show n - - -- | Determine the constructors bound by a data or newtype declaration. Errors out if supplied with another - -- sort of declaration. - decCons :: Dec -> [Con] - decCons d = case d of -+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 - DataD _ _ _ _ cs _ -> cs - NewtypeD _ _ _ _ c _ -> [c] -- _ -> error "decCons: Declaration found was not a data or newtype declaration." -- ---- | Determines the name of a data constructor. It's an error if the 'Con' binds more than one name (which ---- happens in the case where you use GADT syntax, and give multiple data constructor names separated by commas ---- in a type signature in the where clause). --conName :: Con -> Name --conName c = case c of -- NormalC n _ -> n -- RecC n _ -> n -- InfixC _ n _ -> n -- ForallC _ _ c' -> conName c' --#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 -- GadtC [n] _ _ -> n -- RecGadtC [n] _ _ -> n -+#else -+ DataD _ _ _ cs _ -> cs -+ NewtypeD _ _ _ c _ -> [c] - #endif -- _ -> error "conName: GADT constructors with multiple names not yet supported" -+ _ -> error "decCons: Declaration found was not a data or newtype declaration." - - -- | Determine the arity of a data constructor. - conArity :: Con -> Int --- -2.32.0 - - -From fa4b841c14fd8767ac85506b24c2f27a8dc4d2e0 Mon Sep 17 00:00:00 2001 -From: Ali Abrar <[email protected]> -Date: Fri, 10 May 2019 12:15:10 -0400 -Subject: [PATCH 10/14] Fixes for GHC 7.0.4, 7.4.2, 7.6.3, 7.8.4, and 7.10.3 - -Note that the ForallT case of `substVarsWith` is not implemented for -GHCs prior to 7.10.3. ---- - src/Language/Haskell/TH/Extras.hs | 43 +++++++++++++++++++------------ - 1 file changed, 26 insertions(+), 17 deletions(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index 2241d62..cc2c691 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -4,11 +4,13 @@ module Language.Haskell.TH.Extras where - import Control.Monad - import Data.Generics - import Data.Maybe -+import Data.Set (Set) - import qualified Data.Set as Set - import Language.Haskell.TH -+import Language.Haskell.TH.Syntax - - intIs64 :: Bool --intIs64 = toInteger (maxBound :: Int) > 2^32 -+intIs64 = toInteger (maxBound :: Int) > 2^(32 :: Integer) - - replace :: (a -> Maybe a) -> (a -> a) - replace = ap fromMaybe -@@ -28,7 +30,9 @@ nameOfCon (InfixC _ name _) = name - nameOfCon (ForallC _ _ con) = nameOfCon con - #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 - nameOfCon (GadtC [name] _ _) = name -+nameOfCon (GadtC _ _ _) = error $ "nameOfCon: GadtC: only single constructor names are supported" - nameOfCon (RecGadtC [name] _ _) = name -+nameOfCon (RecGadtC _ _ _) = error $ "nameOfCon: RecGadtC: only single constructor names are supported" - #endif - - -- |WARNING: discards binders in GADTs and existentially-quantified constructors -@@ -132,28 +136,29 @@ headOfType (TupleT n) = tupleTypeName n - headOfType ArrowT = ''(->) - headOfType ListT = ''[] - headOfType (AppT t _) = headOfType t -- - #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 - headOfType (SigT t _) = headOfType t - #endif -- - #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 702 - headOfType (UnboxedTupleT n) = unboxedTupleTypeName n - #endif -+#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 704 -+headOfType ty = error $ "headOfType: Unhandled type: " ++ show ty -+#endif - - occursInType :: Name -> Type -> Bool - occursInType var ty = case ty of -- ForallT bndrs _ ty -+ ForallT bndrs _ ty' - | any (var ==) (map nameOfBinder bndrs) - -> False - | otherwise -- -> occursInType var ty -+ -> occursInType var ty' - VarT name - | name == var -> True - | otherwise -> False - AppT ty1 ty2 -> occursInType var ty1 || occursInType var ty2 - #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 -- SigT ty _ -> occursInType var ty -+ SigT ty' _ -> occursInType var ty' - #endif - _ -> False - -@@ -170,13 +175,16 @@ substVarsWith topVars resultType argType = subst Set.empty argType - where - topVars' = reverse topVars - AppT resultType' _indexType = resultType -+ subst :: Set Name -> Type -> Type - subst bs ty = case ty of - -- Several of the following cases could all be covered by an "x -> x" case, but - -- I'd rather know if new cases need to be handled specially in future versions - -- of Template Haskell. -+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 710 - ForallT bndrs cxt t -> -- let bs' = Set.union bs (Set.fromList (map tyVarBndrName bndrs)) -+ let bs' = Set.union bs (Set.fromList (map nameOfBinder bndrs)) - in ForallT bndrs (map (subst bs') cxt) (subst bs' t) -+#endif - AppT f x -> AppT (subst bs f) (subst bs x) - SigT t k -> SigT (subst bs t) k - VarT v -> if Set.member v bs -@@ -193,10 +201,10 @@ substVarsWith topVars resultType argType = subst Set.empty argType - UnboxedSumT k -> UnboxedSumT k - WildCardT -> WildCardT - #endif --#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 784 -+#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 710 - EqualityT -> EqualityT - #endif --#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 763 -+#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 706 - ConstraintT -> ConstraintT - LitT l -> LitT l - PromotedConsT -> PromotedConsT -@@ -205,7 +213,7 @@ substVarsWith topVars resultType argType = subst Set.empty argType - PromotedTupleT k -> PromotedTupleT k - StarT -> StarT - #endif --#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 704 -+#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 700 - UnboxedTupleT k -> UnboxedTupleT k - #endif - findVar v (tv:_) (AppT _ (VarT v')) | v == v' = tv -@@ -213,22 +221,23 @@ substVarsWith topVars resultType argType = subst Set.empty argType - findVar v _ _ = error $ "substVarsWith: couldn't look up variable substitution for " ++ show v - ++ " with topVars: " ++ show topVars ++ " resultType: " ++ show resultType ++ " argType: " ++ show argType - ---- | Determine the 'Name' being bound by a 'TyVarBndr'. --tyVarBndrName :: TyVarBndr -> Name --tyVarBndrName tvb = case tvb of -- PlainTV n -> n -- KindedTV n _ -> n -- - -- | Determine the arity of a kind. -+-- Starting in template-haskell 2.8.0.0, 'Kind' and 'Type' became synonymous. - kindArity :: Kind -> Int -+#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706 -+kindArity k = case k of -+ StarK -> 0 -+ ArrowK k1 k2 -> 1 + kindArity k1 + kindArity k2 -+#else - kindArity k = case k of - ForallT _ _ t -> kindArity t - AppT (AppT ArrowT _) t -> 1 + kindArity t - SigT t _ -> kindArity t --#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 -+#if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 800 - ParensT t -> kindArity t - #endif - _ -> 0 -+#endif - - -- | Given the name of a type constructor, determine its full arity - tyConArity :: Name -> Q Int --- -2.32.0 - - -From cf97836182b68a8431bea19f7d404e807c38a1f5 Mon Sep 17 00:00:00 2001 -From: Ali Abrar <[email protected]> -Date: Fri, 10 May 2019 12:18:20 -0400 -Subject: [PATCH 11/14] Add error message for unhandled ForallT in - substVarsWith for GHC < 7.10 - ---- - src/Language/Haskell/TH/Extras.hs | 2 ++ - 1 file changed, 2 insertions(+) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index cc2c691..57e39cc 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -184,6 +184,8 @@ substVarsWith topVars resultType argType = subst Set.empty argType - ForallT bndrs cxt t -> - let bs' = Set.union bs (Set.fromList (map nameOfBinder bndrs)) - in ForallT bndrs (map (subst bs') cxt) (subst bs' t) -+#else -+ ForallT {} -> error "substVarsWith: ForallT substitutions have not been implemented for GHCs prior to 7.10" - #endif - AppT f x -> AppT (subst bs f) (subst bs x) - SigT t k -> SigT (subst bs t) k --- -2.32.0 - - -From bed3ec182f13fa4af8d91807da1de770f655d316 Mon Sep 17 00:00:00 2001 -From: Ali Abrar <[email protected]> -Date: Fri, 10 May 2019 12:39:29 -0400 -Subject: [PATCH 12/14] Fix old-GHC kindArity implementation - ---- - src/Language/Haskell/TH/Extras.hs | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index 57e39cc..ea57eed 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -229,7 +229,7 @@ kindArity :: Kind -> Int - #if defined (__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706 - kindArity k = case k of - StarK -> 0 -- ArrowK k1 k2 -> 1 + kindArity k1 + kindArity k2 -+ ArrowK _ k2 -> 1 + kindArity k2 - #else - kindArity k = case k of - ForallT _ _ t -> kindArity t --- -2.32.0 - - -From 57a97b4df128eb7b360e8ab9c5759392de8d1659 Mon Sep 17 00:00:00 2001 -From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= <[email protected]> -Date: Mon, 29 Mar 2021 10:36:30 +0800 -Subject: [PATCH 13/14] Add support for ghc-9.0.1 - -Fixes #7 ---- - src/Language/Haskell/TH/Extras.hs | 19 +++++++------------ - th-extras.cabal | 7 ++++--- - 2 files changed, 11 insertions(+), 15 deletions(-) - -diff --git a/src/Language/Haskell/TH/Extras.hs b/src/Language/Haskell/TH/Extras.hs -index ea57eed..eb3b2fe 100644 ---- a/src/Language/Haskell/TH/Extras.hs -+++ b/src/Language/Haskell/TH/Extras.hs -@@ -8,6 +8,7 @@ import Data.Set (Set) - import qualified Data.Set as Set - import Language.Haskell.TH - import Language.Haskell.TH.Syntax -+import Language.Haskell.TH.Datatype.TyVarBndr - - intIs64 :: Bool - intIs64 = toInteger (maxBound :: Int) > 2^(32 :: Integer) -@@ -46,16 +47,10 @@ argTypesOfCon (GadtC _ args _) = map snd args - argTypesOfCon (RecGadtC _ args _) = [t | (_,_,t) <- args] - #endif - --nameOfBinder :: TyVarBndr -> Name --#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 700 --nameOfBinder (PlainTV n) = n --nameOfBinder (KindedTV n _) = n --#else --nameOfBinder = id --type TyVarBndr = Name --#endif -+nameOfBinder :: TyVarBndr_ a -> Name -+nameOfBinder = tvName - --varsBoundInCon :: Con -> [TyVarBndr] -+varsBoundInCon :: Con -> [TyVarBndrSpec] - varsBoundInCon (ForallC bndrs _ con) = bndrs ++ varsBoundInCon con - varsBoundInCon _ = [] - -@@ -149,7 +144,7 @@ headOfType ty = error $ "headOfType: Unhandled type: " ++ show ty - occursInType :: Name -> Type -> Bool - occursInType var ty = case ty of - ForallT bndrs _ ty' -- | any (var ==) (map nameOfBinder bndrs) -+ | any (var ==) (map tvName bndrs) - -> False - | otherwise - -> occursInType var ty' -@@ -182,7 +177,7 @@ substVarsWith topVars resultType argType = subst Set.empty argType - -- of Template Haskell. - #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 710 - ForallT bndrs cxt t -> -- let bs' = Set.union bs (Set.fromList (map nameOfBinder bndrs)) -+ let bs' = Set.union bs (Set.fromList (map tvName bndrs)) - in ForallT bndrs (map (subst bs') cxt) (subst bs' t) - #else - ForallT {} -> error "substVarsWith: ForallT substitutions have not been implemented for GHCs prior to 7.10" -@@ -251,7 +246,7 @@ tyConArity n = do - -- its declaration, and the arity of the kind of type being defined (i.e. how many more arguments would - -- need to be supplied in addition to the bound parameters in order to obtain an ordinary type of kind *). - -- If the supplied 'Name' is anything other than a data or newtype, produces an error. --tyConArity' :: Name -> Q ([TyVarBndr], Int) -+tyConArity' :: Name -> Q ([TyVarBndrUnit], Int) - tyConArity' n = do - r <- reify n - return $ case r of -diff --git a/th-extras.cabal b/th-extras.cabal -index 5031a5d..0c38ff7 100644 ---- a/th-extras.cabal -+++ b/th-extras.cabal -@@ -2,7 +2,7 @@ name: th-extras - version: 0.0.0.4 - stability: experimental - --cabal-version: >= 1.6 -+cabal-version: >= 1.8 - build-type: Simple - - author: James Cook <[email protected]> -@@ -34,7 +34,8 @@ Library - exposed-modules: Language.Haskell.TH.Extras - build-depends: base >= 3 && < 5, - containers, -- template-haskell -- -+ template-haskell, -+ th-abstraction >= 0.4 && < 0.5 -+ - if flag(base4) - build-depends: base >= 4, syb --- -2.32.0 - - -From 5bf8ead4af65ef90fd004e2f9a90de707e40faa3 Mon Sep 17 00:00:00 2001 -From: =?UTF-8?q?Andreas=20K=C3=A4llberg?= <[email protected]> -Date: Sun, 30 May 2021 09:39:36 +0800 -Subject: [PATCH 14/14] Add upper bound for template-haskell - ---- - th-extras.cabal | 2 +- - 1 file changed, 1 insertion(+), 1 deletion(-) - -diff --git a/th-extras.cabal b/th-extras.cabal -index 0c38ff7..3f7bf7a 100644 ---- a/th-extras.cabal -+++ b/th-extras.cabal -@@ -34,7 +34,7 @@ Library - exposed-modules: Language.Haskell.TH.Extras - build-depends: base >= 3 && < 5, - containers, -- template-haskell, -+ template-haskell < 2.18, - th-abstraction >= 0.4 && < 0.5 - - if flag(base4) --- -2.32.0 -
