From f97834492b516a7195bf89b92ea4e48b7939c49c Mon Sep 17 00:00:00 2001
From: sheaf <sam.derbyshire@gmail.com>
Date: Wed, 29 Mar 2023 16:44:11 +0200
Subject: [PATCH] Patches for GHC MR !8686
These patches adapt to the changes in template-haskell-2.21.0.0
introduced by GHC MR !8686: GADT constructors now take a non-empty list.
Packages affected:
- freer-simple, 1.2.1.2
- th-abstraction, 0.4.5.0 and 0.5.0.0
- true-name, 0.1.0.3
---
patches/freer-simple-1.2.1.2.patch | 40 ++++++++++++++++
patches/th-abstraction-0.4.5.0.patch | 45 +++++++++++++++++
patches/th-abstraction-0.5.0.0.patch | 45 +++++++++++++++++
patches/true-name-0.1.0.3.patch | 72 ++++++++++++++++++++++++----
4 files changed, 193 insertions(+), 9 deletions(-)
create mode 100644 patches/th-abstraction-0.4.5.0.patch
create mode 100644 patches/th-abstraction-0.5.0.0.patch
diff --git a/patches/freer-simple-1.2.1.2.patch b/patches/freer-simple-1.2.1.2.patch
index a5432f30..008cb0f5 100644
--- a/patches/freer-simple-1.2.1.2.patch
+++ b/patches/freer-simple-1.2.1.2.patch
@@ -10,4 +10,44 @@ index de96a4c..c298790 100644
+instance (Monad b, MonadBase b m, LastMember m effs) => MonadBase b (Eff effs) where
liftBase = sendM . liftBase
{-# INLINE liftBase #-}
+diff -ru freer-simple-1.2.1.2/src/Control/Monad/Freer/TH.hs freer-simple-1.2.1.2-patched/src/Control/Monad/Freer/TH.hs
+--- freer-simple-1.2.1.2/src/Control/Monad/Freer/TH.hs 2001-09-09 03:46:40.000000000 +0200
++++ freer-simple-1.2.1.2-patched/src/Control/Monad/Freer/TH.hs 2023-03-29 14:38:53.894487600 +0200
+@@ -40,6 +40,11 @@
+ import Language.Haskell.TH
+ import Prelude
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++import Data.List.NonEmpty (NonEmpty(..))
++#endif
++
+
+ -- | If @T@ is a GADT representing an effect algebra, as described in the module
+ -- documentation for "Control.Monad.Freer", @$('makeEffect' ''T)@ automatically
+@@ -95,7 +100,12 @@
+ -- | Builds a function definition of the form @x a b c = send $ X a b c@.
+ genDecl :: Con -> Q Dec
+ genDecl (ForallC _ _ con) = genDecl con
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++genDecl (GadtC (cName :| _) tArgs _ ) = do
++#else
+ genDecl (GadtC [cName] tArgs _ ) = do
++#endif
+ let fnName = getDeclName cName
+ let arity = length tArgs - 1
+ dTypeVars <- forM [0 .. arity] $ const $ newName "a"
+@@ -161,7 +171,12 @@
+ genSig con = do
+ let
+ getConName (ForallC _ _ c) = getConName c
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++ getConName (GadtC (n :| _) _ _) = pure n
++#else
+ getConName (GadtC [n] _ _) = pure n
++#endif
+ getConName c = fail $ "failed to get GADT name from " ++ show c
+ conName <- getConName con
+ SigD (getDeclName conName) <$> simplifyBndrs <$> genType con
diff --git a/patches/th-abstraction-0.4.5.0.patch b/patches/th-abstraction-0.4.5.0.patch
new file mode 100644
index 00000000..14b76f0a
--- /dev/null
+++ b/patches/th-abstraction-0.4.5.0.patch
@@ -0,0 +1,45 @@
+Only in th-abstraction-0.4.5.0-patched: dist-newstyle
+diff -ru th-abstraction-0.4.5.0/src/Language/Haskell/TH/Datatype.hs th-abstraction-0.4.5.0-patched/src/Language/Haskell/TH/Datatype.hs
+--- th-abstraction-0.4.5.0/src/Language/Haskell/TH/Datatype.hs 2001-09-09 03:46:40.000000000 +0200
++++ th-abstraction-0.4.5.0-patched/src/Language/Haskell/TH/Datatype.hs 2023-03-29 14:38:52.597270700 +0200
+@@ -127,6 +127,10 @@
+ import Data.Data (Typeable, Data)
+ import Data.Foldable (foldMap, foldl')
+ import Data.List (mapAccumL, nub, find, union, (\\))
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++import Data.List.NonEmpty (toList)
++#endif
+ import Data.Map (Map)
+ import qualified Data.Map as Map
+ import Data.Maybe
+@@ -910,12 +914,26 @@
+ GadtC ns xs innerType ->
+ let (bangs, ts) = unzip xs
+ stricts = map normalizeStrictness bangs in
+- gadtCase ns innerType ts stricts (checkGadtFixity ts)
++ gadtCase
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++ (toList ns)
++#else
++ ns
++#endif
++ innerType ts stricts (checkGadtFixity ts)
+ RecGadtC ns xs innerType ->
+ let fns = takeFieldNames xs
+ stricts = takeFieldStrictness xs in
+- gadtCase ns innerType (takeFieldTypes xs) stricts
+- (const $ return $ RecordConstructor fns)
++ gadtCase
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++ (toList ns)
++#else
++ ns
++#endif
++ innerType (takeFieldTypes xs) stricts
++ (const $ return $ RecordConstructor fns)
+ where
+ gadtCase = normalizeGadtC typename params instTys tyvars context
+ #endif
diff --git a/patches/th-abstraction-0.5.0.0.patch b/patches/th-abstraction-0.5.0.0.patch
new file mode 100644
index 00000000..e2ae4af7
--- /dev/null
+++ b/patches/th-abstraction-0.5.0.0.patch
@@ -0,0 +1,45 @@
+Only in th-abstraction-0.5.0.0-patched: dist-newstyle
+diff -ru th-abstraction-0.5.0.0/src/Language/Haskell/TH/Datatype.hs th-abstraction-0.5.0.0-patched/src/Language/Haskell/TH/Datatype.hs
+--- th-abstraction-0.5.0.0/src/Language/Haskell/TH/Datatype.hs 2001-09-09 03:46:40.000000000 +0200
++++ th-abstraction-0.5.0.0-patched/src/Language/Haskell/TH/Datatype.hs 2023-03-29 14:38:52.597270700 +0200
+@@ -127,6 +127,10 @@
+ import Data.Data (Typeable, Data)
+ import Data.Foldable (foldMap, foldl')
+ import Data.List (mapAccumL, nub, find, union, (\\))
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++import Data.List.NonEmpty (toList)
++#endif
+ import Data.Map (Map)
+ import qualified Data.Map as Map
+ import Data.Maybe
+@@ -936,12 +940,26 @@
+ GadtC ns xs innerType ->
+ let (bangs, ts) = unzip xs
+ stricts = map normalizeStrictness bangs in
+- gadtCase ns innerType ts stricts (checkGadtFixity ts)
++ gadtCase
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++ (toList ns)
++#else
++ ns
++#endif
++ innerType ts stricts (checkGadtFixity ts)
+ RecGadtC ns xs innerType ->
+ let fns = takeFieldNames xs
+ stricts = takeFieldStrictness xs in
+- gadtCase ns innerType (takeFieldTypes xs) stricts
+- (const $ return $ RecordConstructor fns)
++ gadtCase
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++ (toList ns)
++#else
++ ns
++#endif
++ innerType (takeFieldTypes xs) stricts
++ (const $ return $ RecordConstructor fns)
+ where
+ gadtCase = normalizeGadtC typename params instTys tyvars context
+ #endif
diff --git a/patches/true-name-0.1.0.3.patch b/patches/true-name-0.1.0.3.patch
index eb67b873..b932b080 100644
--- a/patches/true-name-0.1.0.3.patch
+++ b/patches/true-name-0.1.0.3.patch
@@ -1,11 +1,48 @@
-diff --git a/Unsafe/TrueName.hs b/Unsafe/TrueName.hs
-index cab1bc1..40423aa 100644
---- a/Unsafe/TrueName.hs
-+++ b/Unsafe/TrueName.hs
-@@ -65,6 +65,11 @@ decNames dec = case dec of
+diff -ru true-name-0.1.0.3/Unsafe/TrueName.hs true-name-0.1.0.3-patched/Unsafe/TrueName.hs
+--- true-name-0.1.0.3/Unsafe/TrueName.hs 2017-08-24 10:52:46.000000000 +0200
++++ true-name-0.1.0.3-patched/Unsafe/TrueName.hs 2023-03-29 14:43:52.452093300 +0200
+@@ -10,6 +10,10 @@
#endif
+ import Control.Monad
+ import Data.List (nub)
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++import Data.List.NonEmpty (toList)
++#endif
+ import Language.Haskell.TH.Ppr
+ import Language.Haskell.TH.PprLib
+ import Language.Haskell.TH.Quote
+@@ -23,8 +27,22 @@
+ ForallC _ _ con' -> conNames con'
- #if MIN_VERSION_template_haskell(2,12,0)
+ #if MIN_VERSION_template_haskell(2,11,0)
+- GadtC names _ typ -> names ++ typNames typ
+- RecGadtC names vbts typ -> names ++ typNames typ
++ GadtC names _ typ ->
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++ toList names
++#else
++ names
++#endif
++ ++ typNames typ
++ RecGadtC names vbts typ ->
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++ toList names
++#else
++ names
++#endif
++ ++ typNames typ
+ ++ [ fname | (fname, _, _) <- vbts]
+ #endif
+ {- }}} -}
+@@ -64,7 +82,12 @@
+ InfixD _ _ -> []
+ #endif
+
+-#if MIN_VERSION_template_haskell(2,12,0)
++#if MIN_VERSION_template_haskell(2,15,0)
+ DataInstD cxt _mbtvs _ntyps _kind cons derivs ->
+ datatypeNames cxt cons ++ derivNames derivs
+ NewtypeInstD cxt _mbtvs _ntyps _kind con derivs ->
@@ -14,7 +51,7 @@ index cab1bc1..40423aa 100644
DataInstD cxt _name _typs _kind cons derivs ->
datatypeNames cxt cons ++ derivNames derivs
NewtypeInstD cxt _name _typs _kind con derivs ->
-@@ -93,7 +98,11 @@ decNames dec = case dec of
+@@ -93,7 +116,12 @@
#endif
#if MIN_VERSION_template_haskell(2,9,0)
@@ -27,7 +64,7 @@ index cab1bc1..40423aa 100644
RoleAnnotD _ _ -> []
#else
TySynInstD _ ts t -> (typNames =<< ts) ++ typNames t
-@@ -121,7 +130,19 @@ derivNames derivs = predNames =<<
+@@ -121,7 +149,19 @@
#if MIN_VERSION_template_haskell(2,9,0)
tseNames :: TySynEqn -> [Name]
@@ -47,7 +84,7 @@ index cab1bc1..40423aa 100644
#endif
predNames :: Pred -> [Name]{- {{{ -}
-@@ -321,7 +342,11 @@ truename = QuasiQuoter
+@@ -321,7 +361,11 @@
_ -> err $ occString occ ++ " has a strange flavour"
makeP (name, vars) = if vars == [".."]
then RecP name . capture VarP <$> recFields name
@@ -60,3 +97,20 @@ index cab1bc1..40423aa 100644
pat n = case n of
"_" -> WildP
'!' : ns -> BangP (pat ns)
+@@ -359,7 +403,15 @@
+ ForallC _ _ c -> fields c
+ #if MIN_VERSION_template_haskell(2,11,0)
+ GadtC _ _ _ -> []
+- RecGadtC ns vbts _ -> if name `notElem` ns then []
++ RecGadtC ns vbts _ ->
++ if name `notElem`
++-- TODO: use MIN_VERSION_template_haskell(2,21,0)
++#if __GLASGOW_HASKELL__ >= 907
++ toList ns
++#else
++ ns
++#endif
++ then []
+ else [ v | (v, _, _) <- vbts ]
+ #endif
+
--
GitLab