Skip to content
Snippets Groups Projects
Commit f9783449 authored by sheaf's avatar sheaf
Browse files

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
parent 70879358
No related branches found
No related tags found
No related merge requests found
Pipeline #65008 failed
...@@ -10,4 +10,44 @@ index de96a4c..c298790 100644 ...@@ -10,4 +10,44 @@ index de96a4c..c298790 100644
+instance (Monad b, MonadBase b m, LastMember m effs) => MonadBase b (Eff effs) where +instance (Monad b, MonadBase b m, LastMember m effs) => MonadBase b (Eff effs) where
liftBase = sendM . liftBase liftBase = sendM . liftBase
{-# INLINE 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
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
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/Unsafe/TrueName.hs b/Unsafe/TrueName.hs diff -ru true-name-0.1.0.3/Unsafe/TrueName.hs true-name-0.1.0.3-patched/Unsafe/TrueName.hs
index cab1bc1..40423aa 100644 --- true-name-0.1.0.3/Unsafe/TrueName.hs 2017-08-24 10:52:46.000000000 +0200
--- a/Unsafe/TrueName.hs +++ true-name-0.1.0.3-patched/Unsafe/TrueName.hs 2023-03-29 14:43:52.452093300 +0200
+++ b/Unsafe/TrueName.hs @@ -10,6 +10,10 @@
@@ -65,6 +65,11 @@ decNames dec = case dec of
#endif #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 -> + DataInstD cxt _mbtvs _ntyps _kind cons derivs ->
+ datatypeNames cxt cons ++ derivNames derivs + datatypeNames cxt cons ++ derivNames derivs
+ NewtypeInstD cxt _mbtvs _ntyps _kind con derivs -> + NewtypeInstD cxt _mbtvs _ntyps _kind con derivs ->
...@@ -14,7 +51,7 @@ index cab1bc1..40423aa 100644 ...@@ -14,7 +51,7 @@ index cab1bc1..40423aa 100644
DataInstD cxt _name _typs _kind cons derivs -> DataInstD cxt _name _typs _kind cons derivs ->
datatypeNames cxt cons ++ derivNames derivs datatypeNames cxt cons ++ derivNames derivs
NewtypeInstD cxt _name _typs _kind con derivs -> NewtypeInstD cxt _name _typs _kind con derivs ->
@@ -93,7 +98,11 @@ decNames dec = case dec of @@ -93,7 +116,12 @@
#endif #endif
#if MIN_VERSION_template_haskell(2,9,0) #if MIN_VERSION_template_haskell(2,9,0)
...@@ -27,7 +64,7 @@ index cab1bc1..40423aa 100644 ...@@ -27,7 +64,7 @@ index cab1bc1..40423aa 100644
RoleAnnotD _ _ -> [] RoleAnnotD _ _ -> []
#else #else
TySynInstD _ ts t -> (typNames =<< ts) ++ typNames t 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) #if MIN_VERSION_template_haskell(2,9,0)
tseNames :: TySynEqn -> [Name] tseNames :: TySynEqn -> [Name]
...@@ -47,7 +84,7 @@ index cab1bc1..40423aa 100644 ...@@ -47,7 +84,7 @@ index cab1bc1..40423aa 100644
#endif #endif
predNames :: Pred -> [Name]{- {{{ -} predNames :: Pred -> [Name]{- {{{ -}
@@ -321,7 +342,11 @@ truename = QuasiQuoter @@ -321,7 +361,11 @@
_ -> err $ occString occ ++ " has a strange flavour" _ -> err $ occString occ ++ " has a strange flavour"
makeP (name, vars) = if vars == [".."] makeP (name, vars) = if vars == [".."]
then RecP name . capture VarP <$> recFields name then RecP name . capture VarP <$> recFields name
...@@ -60,3 +97,20 @@ index cab1bc1..40423aa 100644 ...@@ -60,3 +97,20 @@ index cab1bc1..40423aa 100644
pat n = case n of pat n = case n of
"_" -> WildP "_" -> WildP
'!' : ns -> BangP (pat ns) '!' : 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
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment