[arch-commits] Commit in haskell-th-extras/trunk (PKGBUILD ghc9.patch)
Felix Yan
felixonmars at gemini.archlinux.org
Sun Jan 9 15:00:46 UTC 2022
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 <edward at 4angle.com>
-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 <aliabrar at gmail.com>
-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 <aliabrar at gmail.com>
-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 <aliabrar at gmail.com>
-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 <aliabrar at gmail.com>
-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 <aliabrar at gmail.com>
-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 <aliabrar at gmail.com>
-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 <aliabrar at gmail.com>
-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 <aliabrar at gmail.com>
-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 <aliabrar at gmail.com>
-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?= <anka.213 at gmail.com>
-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 <mokus at deepbondi.net>
-@@ -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?= <anka.213 at gmail.com>
-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
-
More information about the arch-commits
mailing list