Skip to content
Snippets Groups Projects
Commit 1e5114d2 authored by Ryan Scott's avatar Ryan Scott
Browse files

Patch libraries to work with GHC 8.9

parent 17725f0b
No related branches found
No related tags found
No related merge requests found
commit b521da0ed2a96984ec3620bf88624b3074e0bcf7
Author: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Wed Jul 3 13:33:55 2019 -0400
Adapt to template-haskell-2.16.*
diff --git a/Data/FileEmbed.hs b/Data/FileEmbed.hs
index bbd83ee..2fcd48b 100644
--- a/Data/FileEmbed.hs
+++ b/Data/FileEmbed.hs
@@ -143,7 +143,11 @@ pairToExp _root (path, bs) = do
qAddDependentFile $ _root ++ '/' : path
#endif
exp' <- bsToExp bs
- return $! TupE [LitE $ StringL path, exp']
+ return $! TupE $!
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [LitE $ StringL path, exp']
bsToExp :: B.ByteString -> Q Exp
#if MIN_VERSION_template_haskell(2, 5, 0)
commit ef04b7e2b26461c3278a76dc2e1e093ce55d6d02
Author: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Wed Jul 3 13:20:47 2019 -0400
Adapt to building with template-haskell-2.16.*
diff --git a/src/Control/Monad/Free/TH.hs b/src/Control/Monad/Free/TH.hs
index 1a5ace9..856bb39 100644
--- a/src/Control/Monad/Free/TH.hs
+++ b/src/Control/Monad/Free/TH.hs
@@ -112,7 +112,13 @@ mkArg (VarT n) t
, "in a constructor's argument type: `" ++ pprint t ++ "'" ]
let tup = foldl AppT (TupleT $ length ts) ts
xs <- mapM (const $ newName "x") ts
- return $ Captured tup (LamE (map VarP xs) (TupE (map VarE xs)))
+ return $ Captured tup (LamE (map VarP xs) (TupE (map
+#if MIN_VERSION_template_haskell(2,16,0)
+ (Just . VarE)
+#else
+ VarE
+#endif
+ xs)))
_ -> fail $ unlines
[ "expected a type variable `" ++ pprint n ++ "'"
, "or a type like (a1 -> ... -> aN -> " ++ pprint n ++ ")"
diff -ru haskell-src-meta-0.8.2.orig/src/Language/Haskell/Meta/Syntax/Translate.hs haskell-src-meta-0.8.2/src/Language/Haskell/Meta/Syntax/Translate.hs
--- haskell-src-meta-0.8.2.orig/src/Language/Haskell/Meta/Syntax/Translate.hs 2019-02-26 21:44:20.000000000 -0500
+++ haskell-src-meta-0.8.2/src/Language/Haskell/Meta/Syntax/Translate.hs 2019-07-03 13:56:24.764549867 -0400
@@ -85,11 +85,23 @@
instance (ToExp a) => ToExp [a] where
toExp = ListE . fmap toExp
instance (ToExp a, ToExp b) => ToExp (a,b) where
- toExp (a,b) = TupE [toExp a, toExp b]
+ toExp (a,b) = TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [toExp a, toExp b]
instance (ToExp a, ToExp b, ToExp c) => ToExp (a,b,c) where
- toExp (a,b,c) = TupE [toExp a, toExp b, toExp c]
+ toExp (a,b,c) = TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [toExp a, toExp b, toExp c]
instance (ToExp a, ToExp b, ToExp c, ToExp d) => ToExp (a,b,c,d) where
- toExp (a,b,c,d) = TupE [toExp a, toExp b, toExp c, toExp d]
+ toExp (a,b,c,d) = TupE $
+#if MIN_VERSION_template_haskell(2,16,0)
+ map Just
+#endif
+ [toExp a, toExp b, toExp c, toExp d]
instance ToPat Lit where
@@ -250,8 +262,20 @@
toExp (Hs.Case _ e alts) = CaseE (toExp e) (map toMatch alts)
toExp (Hs.Do _ ss) = DoE (map toStmt ss)
toExp e@(Hs.MDo _ _) = noTH "toExp" e
- toExp (Hs.Tuple _ Hs.Boxed xs) = TupE (fmap toExp xs)
- toExp (Hs.Tuple _ Hs.Unboxed xs) = UnboxedTupE (fmap toExp xs)
+ toExp (Hs.Tuple _ Hs.Boxed xs) = TupE (fmap
+#if MIN_VERSION_template_haskell(2,16,0)
+ (Just . toExp)
+#else
+ toExp
+#endif
+ xs)
+ toExp (Hs.Tuple _ Hs.Unboxed xs) = UnboxedTupE (fmap
+#if MIN_VERSION_template_haskell(2,16,0)
+ (Just . toExp)
+#else
+ toExp
+#endif
+ xs)
toExp e@Hs.TupleSection{} = noTH "toExp" e
toExp (Hs.List _ xs) = ListE (fmap toExp xs)
toExp (Hs.Paren _ e) = ParensE (toExp e)
diff -ru haskell-src-meta-0.8.2.orig/src/Language/Haskell/Meta/Utils.hs haskell-src-meta-0.8.2/src/Language/Haskell/Meta/Utils.hs
--- haskell-src-meta-0.8.2.orig/src/Language/Haskell/Meta/Utils.hs 2019-02-26 21:44:20.000000000 -0500
+++ haskell-src-meta-0.8.2/src/Language/Haskell/Meta/Utils.hs 2019-07-03 13:57:37.549286480 -0400
@@ -338,7 +338,13 @@
in replicateM n (newName "a")
>>= \ns -> return (Just (LamE
[ConP dConN (fmap VarP ns)]
- (TupE $ fmap VarE ns)))
+ (TupE $ fmap
+#if MIN_VERSION_template_haskell(2,16,0)
+ (Just . VarE)
+#else
+ VarE
+#endif
+ ns)))
fromDataConI _ = return Nothing
fromTyConI :: Info -> Maybe Dec
diff -ru kind-generics-0.3.0.0.orig/src/Generics/Kind.hs kind-generics-0.3.0.0/src/Generics/Kind.hs
--- kind-generics-0.3.0.0.orig/src/Generics/Kind.hs 2018-12-04 09:04:47.000000000 -0500
+++ kind-generics-0.3.0.0/src/Generics/Kind.hs 2019-07-03 13:39:40.002441920 -0400
@@ -75,7 +75,7 @@
-- > instance GenericK E LoT0 where
-- > type RepK E = Exists (*) (Field Var0)
data Exists k (f :: LoT (k -> d) -> *) (x :: LoT d) where
- Exists :: forall (t :: k) d (f :: LoT (k -> d) -> *) (x :: LoT d)
+ Exists :: forall k (t :: k) d (f :: LoT (k -> d) -> *) (x :: LoT d)
.{ unExists :: f (t ':&&: x) } -> Exists k f x
deriving instance (forall t. Show (f (t ':&&: x))) => Show (Exists k f x)
commit 53e1d423703c3cbce05d73250af107517b235c83 commit 324c0e7a0d9c510b474f9bbc60f358de4566e48a
Author: Ryan Scott <ryan.gl.scott@gmail.com> Author: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri Apr 26 13:38:18 2019 -0400 Date: Wed Jul 3 13:21:45 2019 -0400
Allow building with template-haskell-2.15.0.0 Adapt to building with template-haskell-2.15.*/2.16.*
diff --git a/src/Control/Lens/Internal/TH.hs b/src/Control/Lens/Internal/TH.hs diff --git a/src/Control/Lens/Internal/TH.hs b/src/Control/Lens/Internal/TH.hs
index 6ea63da2..185e47ae 100644 index 6ea63da2..185e47ae 100644
...@@ -66,7 +66,7 @@ index dc7cead1..eff0a99b 100644 ...@@ -66,7 +66,7 @@ index dc7cead1..eff0a99b 100644
data DataDecl = DataDecl data DataDecl = DataDecl
{ dataContext :: Cxt -- ^ Datatype context. { dataContext :: Cxt -- ^ Datatype context.
diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs diff --git a/src/Language/Haskell/TH/Lens.hs b/src/Language/Haskell/TH/Lens.hs
index 9d1b0c88..9a7dbe18 100644 index 9d1b0c88..8d5b8a35 100644
--- a/src/Language/Haskell/TH/Lens.hs --- a/src/Language/Haskell/TH/Lens.hs
+++ b/src/Language/Haskell/TH/Lens.hs +++ b/src/Language/Haskell/TH/Lens.hs
@@ -4,6 +4,10 @@ @@ -4,6 +4,10 @@
...@@ -200,3 +200,37 @@ index 9d1b0c88..9a7dbe18 100644 ...@@ -200,3 +200,37 @@ index 9d1b0c88..9a7dbe18 100644
#endif #endif
_InfixL :: Prism' FixityDirection () _InfixL :: Prism' FixityDirection ()
@@ -1837,7 +1901,15 @@ _TupE
= prism' reviewer remitter
where
reviewer = TupE
- remitter (TupE x) = Just x
+#if MIN_VERSION_template_haskell(2,16,0)
+ . map Just
+#endif
+ remitter (TupE x) =
+#if MIN_VERSION_template_haskell(2,16,0)
+ sequence x
+#else
+ Just x
+#endif
remitter _ = Nothing
_UnboxedTupE :: Prism' Exp [Exp]
@@ -1845,7 +1917,15 @@ _UnboxedTupE
= prism' reviewer remitter
where
reviewer = UnboxedTupE
- remitter (UnboxedTupE x) = Just x
+#if MIN_VERSION_template_haskell(2,16,0)
+ . map Just
+#endif
+ remitter (UnboxedTupE x) =
+#if MIN_VERSION_template_haskell(2,16,0)
+ sequence x
+#else
+ Just x
+#endif
remitter _ = Nothing
#if MIN_VERSION_template_haskell(2,12,0)
commit 04372a6db858203713074dd3b38b68efa17bedee commit 8fd994fad31d160a025ce3274438b0eb4cb21539
Author: Ryan Scott <ryan.gl.scott@gmail.com> Author: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri Mar 15 19:09:33 2019 -0400 Date: Wed Jul 3 14:15:40 2019 -0400
Adapt to base-4.13.0.0 Adapt to base-4.13.*/template-haskell-2.{15.*,16.*}
diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs
index 0f185a1..5e2bea4 100644 index 0cc2f44..69a8014 100644
--- a/Language/Haskell/TH/Desugar/Core.hs --- a/Language/Haskell/TH/Desugar/Core.hs
+++ b/Language/Haskell/TH/Desugar/Core.hs +++ b/Language/Haskell/TH/Desugar/Core.hs
@@ -21,6 +21,7 @@ import Language.Haskell.TH.ExpandSyns ( expandSyns ) @@ -21,6 +21,7 @@ import Language.Haskell.TH.ExpandSyns ( expandSyns )
...@@ -16,69 +16,30 @@ index 0f185a1..5e2bea4 100644 ...@@ -16,69 +16,30 @@ index 0f185a1..5e2bea4 100644
import Control.Monad.Zip import Control.Monad.Zip
import Control.Monad.Writer hiding (forM_, mapM) import Control.Monad.Writer hiding (forM_, mapM)
import Data.Foldable hiding (notElem) import Data.Foldable hiding (notElem)
@@ -1211,7 +1212,7 @@ reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q @@ -72,10 +73,20 @@ dsExp (LamCaseE matches) = do
reorderFieldsPat con_name field_decs field_pats = matches' <- dsMatches x matches
reorderFields' dsPat con_name field_decs field_pats (repeat DWildPa) return $ DLamE [x] (DCaseE (DVarE x) matches')
dsExp (TupE exps) = do
-reorderFields' :: (Applicative m, Monad m) - exps' <- mapM dsExp exps
+reorderFields' :: (Applicative m, Fail.MonadFail m) + exps' <-
=> (a -> m da) +#if MIN_VERSION_template_haskell(2,16,0)
-> Name -- ^ The name of the constructor (used for error reporting) + mapMaybeM (mapM dsExp) exps
-> [VarStrictType] -> [(Name, a)] +#else
@@ -1297,7 +1298,7 @@ strictToBang = id + mapM dsExp exps
#endif +#endif
return $ foldl DAppE (DConE $ tupleDataName (length exps)) exps'
-- | Convert a 'DType' to a 'DPred'. dsExp (UnboxedTupE exps) =
-dTypeToDPred :: Monad q => DType -> q DPred - foldl DAppE (DConE $ unboxedTupleDataName (length exps)) <$> mapM dsExp exps
+dTypeToDPred :: Fail.MonadFail q => DType -> q DPred + foldl DAppE (DConE $ unboxedTupleDataName (length exps)) <$>
dTypeToDPred (DForallT tvbs cxt ty) +#if MIN_VERSION_template_haskell(2,16,0)
= DForallPr tvbs cxt `liftM` dTypeToDPred ty + mapMaybeM (mapM dsExp) exps
dTypeToDPred (DAppT t1 t2) = liftM2 DAppPr (dTypeToDPred t1) (return t2) +#else
diff --git a/Language/Haskell/TH/Desugar/Util.hs b/Language/Haskell/TH/Desugar/Util.hs + mapM dsExp exps
index 3729601..4a74ce5 100644 +#endif
--- a/Language/Haskell/TH/Desugar/Util.hs dsExp (CondE e1 e2 e3) =
+++ b/Language/Haskell/TH/Desugar/Util.hs dsExp (CaseE e1 [ Match (ConP 'True []) (NormalB e2) []
@@ -36,6 +36,7 @@ import Language.Haskell.TH hiding ( cxt ) , Match (ConP 'False []) (NormalB e3) [] ])
import Language.Haskell.TH.Syntax @@ -714,24 +725,40 @@ dsDec (FamilyD DataFam n tvbs m_k) =
import Control.Monad ( replicateM )
+import qualified Control.Monad.Fail as Fail
import qualified Data.Set as S
import Data.Foldable
import Data.Generics hiding ( Fixity )
@@ -104,7 +105,7 @@ stripPlainTV_maybe (PlainTV n) = Just n
stripPlainTV_maybe _ = Nothing
-- | Report that a certain TH construct is impossible
-impossible :: Monad q => String -> q a
+impossible :: Fail.MonadFail q => String -> q a
impossible err = fail (err ++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.")
-- | Extract a 'Name' from a 'TyVarBndr'
@@ -330,7 +331,7 @@ mapMaybeM f (x:xs) = do
Nothing -> ys
Just z -> z : ys
-expectJustM :: Monad m => String -> Maybe a -> m a
+expectJustM :: Fail.MonadFail m => String -> Maybe a -> m a
expectJustM _ (Just x) = return x
expectJustM err Nothing = fail err
commit c98e9a910fa97ee43719748ef1c7cd9d32e578e1
Author: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Fri Mar 15 19:07:41 2019 -0400
Allow building with template-haskell-2.15.0.0
Adapted from
https://github.com/goldfirere/th-desugar/commit/9b9a6f0bdb6becd3f5ae896ddb539069131f7ba0
diff --git a/Language/Haskell/TH/Desugar/Core.hs b/Language/Haskell/TH/Desugar/Core.hs
index 0cc2f44..0f185a1 100644
--- a/Language/Haskell/TH/Desugar/Core.hs
+++ b/Language/Haskell/TH/Desugar/Core.hs
@@ -714,24 +714,40 @@ dsDec (FamilyD DataFam n tvbs m_k) =
(:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k) (:[]) <$> (DDataFamilyD n <$> mapM dsTvb tvbs <*> mapM dsType m_k)
#endif #endif
#if __GLASGOW_HASKELL__ > 710 #if __GLASGOW_HASKELL__ > 710
...@@ -135,7 +96,7 @@ index 0cc2f44..0f185a1 100644 ...@@ -135,7 +96,7 @@ index 0cc2f44..0f185a1 100644
#else #else
dsDec (DataInstD cxt n tys cons derivings) = do dsDec (DataInstD cxt n tys cons derivings) = do
tys' <- mapM dsType tys tys' <- mapM dsType tys
@@ -755,7 +771,20 @@ dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$> @@ -755,7 +782,20 @@ dsDec (TySynInstD n lhs rhs) = (:[]) <$> (DTySynInstD n <$>
(DTySynEqn <$> mapM dsType lhs (DTySynEqn <$> mapM dsType lhs
<*> dsType rhs)) <*> dsType rhs))
#else #else
...@@ -156,7 +117,7 @@ index 0cc2f44..0f185a1 100644 ...@@ -156,7 +117,7 @@ index 0cc2f44..0f185a1 100644
#if __GLASGOW_HASKELL__ > 710 #if __GLASGOW_HASKELL__ > 710
dsDec (ClosedTypeFamilyD tfHead eqns) = dsDec (ClosedTypeFamilyD tfHead eqns) =
(:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead (:[]) <$> (DClosedTypeFamilyD <$> dsTypeFamilyHead tfHead
@@ -961,7 +990,11 @@ dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty @@ -961,7 +1001,11 @@ dsPragma (SpecialiseP n ty m_inl phases) = DSpecialiseP n <$> dsType ty
<*> pure m_inl <*> pure m_inl
<*> pure phases <*> pure phases
dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty dsPragma (SpecialiseInstP ty) = DSpecialiseInstP <$> dsType ty
...@@ -169,7 +130,7 @@ index 0cc2f44..0f185a1 100644 ...@@ -169,7 +130,7 @@ index 0cc2f44..0f185a1 100644
<*> dsExp lhs <*> dsExp lhs
<*> dsExp rhs <*> dsExp rhs
<*> pure phases <*> pure phases
@@ -983,7 +1016,14 @@ dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty @@ -983,7 +1027,14 @@ dsRuleBndr (TypedRuleVar n ty) = DTypedRuleVar n <$> dsType ty
#if __GLASGOW_HASKELL__ >= 707 #if __GLASGOW_HASKELL__ >= 707
-- | Desugar a @TySynEqn@. (Available only with GHC 7.8+) -- | Desugar a @TySynEqn@. (Available only with GHC 7.8+)
dsTySynEqn :: DsMonad q => TySynEqn -> q DTySynEqn dsTySynEqn :: DsMonad q => TySynEqn -> q DTySynEqn
...@@ -184,6 +145,24 @@ index 0cc2f44..0f185a1 100644 ...@@ -184,6 +145,24 @@ index 0cc2f44..0f185a1 100644
#endif #endif
-- | Desugar clauses to a function definition -- | Desugar clauses to a function definition
@@ -1171,7 +1222,7 @@ reorderFieldsPat :: DsMonad q => Name -> [VarStrictType] -> [FieldPat] -> PatM q
reorderFieldsPat con_name field_decs field_pats =
reorderFields' dsPat con_name field_decs field_pats (repeat DWildPa)
-reorderFields' :: (Applicative m, Monad m)
+reorderFields' :: (Applicative m, Fail.MonadFail m)
=> (a -> m da)
-> Name -- ^ The name of the constructor (used for error reporting)
-> [VarStrictType] -> [(Name, a)]
@@ -1257,7 +1308,7 @@ strictToBang = id
#endif
-- | Convert a 'DType' to a 'DPred'.
-dTypeToDPred :: Monad q => DType -> q DPred
+dTypeToDPred :: Fail.MonadFail q => DType -> q DPred
dTypeToDPred (DForallT tvbs cxt ty)
= DForallPr tvbs cxt `liftM` dTypeToDPred ty
dTypeToDPred (DAppT t1 t2) = liftM2 DAppPr (dTypeToDPred t1) (return t2)
diff --git a/Language/Haskell/TH/Desugar/Reify.hs b/Language/Haskell/TH/Desugar/Reify.hs diff --git a/Language/Haskell/TH/Desugar/Reify.hs b/Language/Haskell/TH/Desugar/Reify.hs
index d04c297..e2bd3ae 100644 index d04c297..e2bd3ae 100644
--- a/Language/Haskell/TH/Desugar/Reify.hs --- a/Language/Haskell/TH/Desugar/Reify.hs
...@@ -321,7 +300,7 @@ index bb257c3..2289faa 100644 ...@@ -321,7 +300,7 @@ index bb257c3..2289faa 100644
clauseToTH :: DClause -> Clause clauseToTH :: DClause -> Clause
diff --git a/Language/Haskell/TH/Desugar/Util.hs b/Language/Haskell/TH/Desugar/Util.hs diff --git a/Language/Haskell/TH/Desugar/Util.hs b/Language/Haskell/TH/Desugar/Util.hs
index 2fe6283..3729601 100644 index 2fe6283..4a74ce5 100644
--- a/Language/Haskell/TH/Desugar/Util.hs --- a/Language/Haskell/TH/Desugar/Util.hs
+++ b/Language/Haskell/TH/Desugar/Util.hs +++ b/Language/Haskell/TH/Desugar/Util.hs
@@ -27,7 +27,7 @@ module Language.Haskell.TH.Desugar.Util ( @@ -27,7 +27,7 @@ module Language.Haskell.TH.Desugar.Util (
...@@ -333,7 +312,33 @@ index 2fe6283..3729601 100644 ...@@ -333,7 +312,33 @@ index 2fe6283..3729601 100644
) where ) where
import Prelude hiding (mapM, foldl, concatMap, any) import Prelude hiding (mapM, foldl, concatMap, any)
@@ -394,3 +394,12 @@ uniStarKindName = ''(Kind.★) @@ -36,6 +36,7 @@ import Language.Haskell.TH hiding ( cxt )
import Language.Haskell.TH.Syntax
import Control.Monad ( replicateM )
+import qualified Control.Monad.Fail as Fail
import qualified Data.Set as S
import Data.Foldable
import Data.Generics hiding ( Fixity )
@@ -104,7 +105,7 @@ stripPlainTV_maybe (PlainTV n) = Just n
stripPlainTV_maybe _ = Nothing
-- | Report that a certain TH construct is impossible
-impossible :: Monad q => String -> q a
+impossible :: Fail.MonadFail q => String -> q a
impossible err = fail (err ++ "\n This should not happen in Haskell.\n Please email rae@cs.brynmawr.edu with your code if you see this.")
-- | Extract a 'Name' from a 'TyVarBndr'
@@ -330,7 +331,7 @@ mapMaybeM f (x:xs) = do
Nothing -> ys
Just z -> z : ys
-expectJustM :: Monad m => String -> Maybe a -> m a
+expectJustM :: Fail.MonadFail m => String -> Maybe a -> m a
expectJustM _ (Just x) = return x
expectJustM err Nothing = fail err
@@ -394,3 +395,12 @@ uniStarKindName = ''(Kind.★)
uniStarKindName = starKindName uniStarKindName = starKindName
#endif #endif
#endif #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