[arch-commits] Commit in haskell-th-extras/repos (3 files)
Felix Yan
felixonmars at gemini.archlinux.org
Wed Jan 5 21:16:26 UTC 2022
Date: Wednesday, January 5, 2022 @ 21:16:26
Author: felixonmars
Revision: 1093615
archrelease: copy trunk to community-staging-x86_64
Added:
haskell-th-extras/repos/community-staging-x86_64/
haskell-th-extras/repos/community-staging-x86_64/PKGBUILD
(from rev 1093614, haskell-th-extras/trunk/PKGBUILD)
haskell-th-extras/repos/community-staging-x86_64/ghc9.patch
(from rev 1093614, haskell-th-extras/trunk/ghc9.patch)
------------+
PKGBUILD | 44 ++
ghc9.patch | 876 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 920 insertions(+)
Copied: haskell-th-extras/repos/community-staging-x86_64/PKGBUILD (from rev 1093614, haskell-th-extras/trunk/PKGBUILD)
===================================================================
--- community-staging-x86_64/PKGBUILD (rev 0)
+++ community-staging-x86_64/PKGBUILD 2022-01-05 21:16:26 UTC (rev 1093615)
@@ -0,0 +1,44 @@
+# Maintainer: Felix Yan <felixonmars at archlinux.org>
+
+_hkgname=th-extras
+pkgname=haskell-th-extras
+pkgver=0.0.0.4
+pkgrel=68
+pkgdesc="A grab bag of functions for use with Template Haskell"
+url="https://github.com/mokus0/th-extras"
+license=("custom:PublicDomain")
+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')
+
+prepare() {
+ patch -d $_hkgname-$pkgver -p1 < ghc9.patch
+}
+
+build() {
+ cd $_hkgname-$pkgver
+
+ runhaskell Setup configure -O --enable-shared --enable-executable-dynamic --disable-library-vanilla \
+ --prefix=/usr --docdir=/usr/share/doc/$pkgname --enable-tests \
+ --dynlibdir=/usr/lib --libsubdir=\$compiler/site-local/\$pkgid --ghc-option=-fllvm \
+ --ghc-option=-optl-Wl\,-z\,relro\,-z\,now \
+ --ghc-option='-pie'
+
+ runhaskell Setup build $MAKEFLAGS
+ runhaskell Setup register --gen-script
+ runhaskell Setup unregister --gen-script
+ sed -i -r -e "s|ghc-pkg.*update[^ ]* |&'--force' |" register.sh
+ sed -i -r -e "s|ghc-pkg.*unregister[^ ]* |&'--force' |" unregister.sh
+}
+
+package() {
+ cd $_hkgname-$pkgver
+
+ install -D -m744 register.sh "$pkgdir"/usr/share/haskell/register/$pkgname.sh
+ install -D -m744 unregister.sh "$pkgdir"/usr/share/haskell/unregister/$pkgname.sh
+ runhaskell Setup copy --destdir="$pkgdir"
+}
Copied: haskell-th-extras/repos/community-staging-x86_64/ghc9.patch (from rev 1093614, haskell-th-extras/trunk/ghc9.patch)
===================================================================
--- community-staging-x86_64/ghc9.patch (rev 0)
+++ community-staging-x86_64/ghc9.patch 2022-01-05 21:16:26 UTC (rev 1093615)
@@ -0,0 +1,876 @@
+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