[arch-commits] Commit in haskell-th-extras/repos (3 files)

Felix Yan felixonmars at gemini.archlinux.org
Fri Jan 7 19:06:51 UTC 2022


    Date: Friday, January 7, 2022 @ 19:06:51
  Author: felixonmars
Revision: 1096099

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 1096098, haskell-th-extras/trunk/PKGBUILD)
  haskell-th-extras/repos/community-staging-x86_64/ghc9.patch
    (from rev 1096098, 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 1096098, haskell-th-extras/trunk/PKGBUILD)
===================================================================
--- community-staging-x86_64/PKGBUILD	                        (rev 0)
+++ community-staging-x86_64/PKGBUILD	2022-01-07 19:06:51 UTC (rev 1096099)
@@ -0,0 +1,44 @@
+# Maintainer: Felix Yan <felixonmars at archlinux.org>
+
+_hkgname=th-extras
+pkgname=haskell-th-extras
+pkgver=0.0.0.4
+pkgrel=69
+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 1096098, haskell-th-extras/trunk/ghc9.patch)
===================================================================
--- community-staging-x86_64/ghc9.patch	                        (rev 0)
+++ community-staging-x86_64/ghc9.patch	2022-01-07 19:06:51 UTC (rev 1096099)
@@ -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