Commit b6f7f3ad authored by Ryan Scott's avatar Ryan Scott
Browse files

Merge branch 'Agda-ST-MonadFail' into 'master'

Avoid MonadFail instance for ST in Agda patch

See merge request ghc/head.hackage!212
parents e5f14af2 6e3c0d12
......@@ -58,6 +58,19 @@ index 5275794..2b13c63 100644
-- the idle GC is now by default turned off (-I0).
ghc-options: -threaded -rtsopts
"-with-rtsopts=-M3.5G -I0"
diff --git a/src/full/Agda/TypeChecking/Reduce/Fast.hs b/src/full/Agda/TypeChecking/Reduce/Fast.hs
index 6fc2596..02e86d3 100644
--- a/src/full/Agda/TypeChecking/Reduce/Fast.hs
+++ b/src/full/Agda/TypeChecking/Reduce/Fast.hs
@@ -503,7 +503,7 @@ derefPointer (Pointer ptr) = readSTRef ptr
-- | In most cases pointers that we dereference do not contain black holes.
derefPointer_ :: Pointer s -> ST s (Closure s)
derefPointer_ ptr = do
- Thunk cl <- derefPointer ptr
+ ~(Thunk cl) <- derefPointer ptr
return cl
-- | Only use for debug printing!
diff --git a/src/full/Agda/TypeChecking/Serialise.hs b/src/full/Agda/TypeChecking/Serialise.hs
index 69c3f70..dfd2cad 100644
--- a/src/full/Agda/TypeChecking/Serialise.hs
......
......@@ -516,7 +516,7 @@ index 86f1147..dc08a8b 100644
| otherwise = empty
where
diff --git a/basement.cabal b/basement.cabal
index 304057b..756d2df 100644
index 7a60516..1d39b81 100644
--- a/basement.cabal
+++ b/basement.cabal
@@ -136,6 +136,8 @@ library
......@@ -526,5 +526,5 @@ index 304057b..756d2df 100644
+ Basement.HeadHackageUtils
+
-- support and dependencies
if impl(ghc < 8.0)
if impl(ghc < 8.8)
buildable: False
diff --git a/src/Data/Geometry/PolyLine.hs b/src/Data/Geometry/PolyLine.hs
index 70df57f..57aec1c 100644
--- a/src/Data/Geometry/PolyLine.hs
+++ b/src/Data/Geometry/PolyLine.hs
@@ -94,7 +94,7 @@ fromPoints = fmap PolyLine . LSeq.eval @2 . LSeq.fromList
-- | pre: The input list contains at least two points
fromPointsUnsafe :: [Point d r :+ p] -> PolyLine d p r
-fromPointsUnsafe = PolyLine . LSeq.forceLSeq (C @ 2) . LSeq.fromList
+fromPointsUnsafe = PolyLine . LSeq.forceLSeq (C @2) . LSeq.fromList
-- | pre: The input list contains at least two points. All extra vields are
-- initialized with mempty.
diff --git a/src/Data/Geometry/RangeTree.hs b/src/Data/Geometry/RangeTree.hs
index e08b39d..d6ec9b6 100644
--- a/src/Data/Geometry/RangeTree.hs
+++ b/src/Data/Geometry/RangeTree.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.Geometry.RangeTree
diff --git a/src/Data/Geometry/RangeTree/Measure.hs b/src/Data/Geometry/RangeTree/Measure.hs
index ed61048..d33ef27 100644
--- a/src/Data/Geometry/RangeTree/Measure.hs
+++ b/src/Data/Geometry/RangeTree/Measure.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-orphans #-}
--------------------------------------------------------------------------------
-- |
@@ -53,11 +54,13 @@ type (:*:) l r = Product l r
instance (LabeledMeasure l, LabeledMeasure r) => LabeledMeasure (l :*: r) where
labeledMeasure xs = Pair (labeledMeasure xs) (labeledMeasure xs)
+#if !(MIN_VERSION_base(4,16,0))
instance (Semigroup (l a), Semigroup (r a)) => Semigroup ((l :*: r) a) where
(Pair l r) <> (Pair l' r') = Pair (l <> l') (r <> r')
instance (Monoid (l a), Monoid (r a)) => Monoid ((l :*: r) a) where
mempty = Pair mempty mempty
+#endif
diff --git a/src/Data/Geometry/Vector/VectorFamily.hs b/src/Data/Geometry/Vector/VectorFamily.hs
index d1f53b4..a0b8a07 100644
--- a/src/Data/Geometry/Vector/VectorFamily.hs
+++ b/src/Data/Geometry/Vector/VectorFamily.hs
@@ -204,7 +204,7 @@ head = view $ element (C :: C 0)
-- | Lens into the i th element
element :: forall proxy i d r. (Arity d, KnownNat i, (i + 1) <= d)
=> proxy i -> Lens' (Vector d r) r
-element _ = singular . element' . fromInteger $ natVal (C :: C i)
+element _ = singular $ element' $ fromInteger $ natVal (C :: C i)
{-# INLINE element #-}
diff --git a/src/Data/Geometry/RangeTree.hs b/src/Data/Geometry/RangeTree.hs
index 1aea06f..586bd17 100644
--- a/src/Data/Geometry/RangeTree.hs
+++ b/src/Data/Geometry/RangeTree.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
--------------------------------------------------------------------------------
-- |
-- Module : Data.Geometry.RangeTree
diff --git a/src/Data/Parameterized/Context/Unsafe.hs b/src/Data/Parameterized/Context/Unsafe.hs
index 43e9def..609f2af 100644
--- a/src/Data/Parameterized/Context/Unsafe.hs
+++ b/src/Data/Parameterized/Context/Unsafe.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE GADTs #-}
diff --git a/src/Data/Parameterized/Fin.hs b/src/Data/Parameterized/Fin.hs
index 6118c9d..fcfbfdc 100644
--- a/src/Data/Parameterized/Fin.hs
+++ b/src/Data/Parameterized/Fin.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
{-|
Copyright : (c) Galois, Inc 2021
diff --git a/src/Data/Parameterized/NatRepr.hs b/src/Data/Parameterized/NatRepr.hs
index e4276a7..181186f 100644
--- a/src/Data/Parameterized/NatRepr.hs
+++ b/src/Data/Parameterized/NatRepr.hs
@@ -129,6 +129,8 @@ module Data.Parameterized.NatRepr
) where
import Data.Bits ((.&.), bit)
+import Data.Constraint (Dict(..))
+import Data.Constraint.Nat (zeroLe)
import Data.Data
import Data.Type.Equality as Equality
import Data.Void as Void
@@ -347,7 +349,7 @@ withSubMulDistribRight _n _m _p f =
-- | @LeqProof m n@ is a type whose values are only inhabited when @m@
-- is less than or equal to @n@.
-data LeqProof m n where
+data LeqProof (m :: Nat) (n :: Nat) where
LeqProof :: (m <= n) => LeqProof m n
-- | (<=) is a decidable relation on nats.
@@ -476,14 +478,14 @@ leqMulMono x y = leqMulCongr (leqProof (Proxy :: Proxy 1) x) (leqRefl y)
-- | Produce proof that adding a value to the larger element in an LeqProof
-- is larger
leqAdd :: forall f m n p . LeqProof m n -> f p -> LeqProof m (n+p)
-leqAdd x _ = leqAdd2 x (LeqProof :: LeqProof 0 p)
+leqAdd x _ = case zeroLe @p of Dict -> leqAdd2 x (LeqProof :: LeqProof 0 p)
leqAddPos :: (1 <= m, 1 <= n) => p m -> q n -> LeqProof 1 (m + n)
leqAddPos m n = leqAdd (leqProof (Proxy :: Proxy 1) m) n
-- | Produce proof that subtracting a value from the smaller element is smaller.
leqSub :: forall m n p . LeqProof m n -> LeqProof p m -> LeqProof (m-p) n
-leqSub x _ = leqSub2 x (LeqProof :: LeqProof 0 p)
+leqSub x _ = case zeroLe @p of Dict -> leqSub2 x (LeqProof :: LeqProof 0 p)
addIsLeq :: f n -> g m -> LeqProof n (n + m)
addIsLeq n m = leqAdd (leqRefl n) m
diff --git a/src/Data/Parameterized/TH/GADT.hs b/src/Data/Parameterized/TH/GADT.hs
index cb3712e..3fb18d3 100644
--- a/src/Data/Parameterized/TH/GADT.hs
+++ b/src/Data/Parameterized/TH/GADT.hs
@@ -8,6 +8,7 @@
-- This module declares template Haskell primitives so that it is easier
-- to work with GADTs that have many constructors.
------------------------------------------------------------------------
+{-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
@@ -66,7 +67,7 @@ conPat ::
Q (Pat, [Name]) {- ^ pattern and bound names -}
conPat con pre = do
nms <- newNames pre (length (constructorFields con))
- return (ConP (constructorName con) (VarP <$> nms), nms)
+ return (conPCompat (constructorName con) (VarP <$> nms), nms)
-- | Return an expression corresponding to the constructor.
@@ -487,7 +488,7 @@ structuralShowsPrec tpq = do
showCon :: ExpQ -> Name -> Int -> MatchQ
showCon p nm n = do
vars <- newNames "x" n
- let pat = ConP nm (VarP <$> vars)
+ let pat = conPCompat nm (VarP <$> vars)
let go s e = [| $(s) . showChar ' ' . showsPrec 11 $(varE e) |]
let ctor = [| showString $(return (LitE (StringL (nameBase nm)))) |]
let rhs | null vars = ctor
@@ -775,3 +776,10 @@ mkReprName nm = mkName (nameBase nm ++ "Repr")
-- NB: These macros are inspired by the corresponding macros provided by
-- @singletons-th@, and the \"repr\" programming idiom is very similar to the one
-- used by @singletons@.
+
+conPCompat :: Name -> [Pat] -> Pat
+conPCompat n pats = ConP n
+#if MIN_VERSION_template_haskell(2,18,0)
+ []
+#endif
+ pats
diff --git a/src/Data/Parameterized/Vector.hs b/src/Data/Parameterized/Vector.hs
index 5ae8b5e..a3456e5 100644
--- a/src/Data/Parameterized/Vector.hs
+++ b/src/Data/Parameterized/Vector.hs
@@ -98,6 +98,8 @@ module Data.Parameterized.Vector
import qualified Data.Vector as Vector
import Data.Coerce
+import Data.Constraint (Dict(..))
+import Data.Constraint.Nat (zeroLe)
import Data.Foldable.WithIndex (FoldableWithIndex(ifoldMap))
import Data.Functor.Compose
import Data.Functor.WithIndex (FunctorWithIndex(imap))
@@ -501,7 +503,7 @@ unfoldrWithIndexM' h gen start =
snd <$> getCompose3 (natRecBounded (decNat h) (decNat h) base step)
}
where base :: Compose3 m ((,) b) (Vector' a) 0
- base = Compose3 $ (\(hd, b) -> (b, MkVector' (singleton hd))) <$> gen (knownNat @0) start
+ base = case zeroLe @h of Dict -> Compose3 $ (\(hd, b) -> (b, MkVector' (singleton hd))) <$> gen (knownNat @0) start
step :: forall p. (1 <= h, p <= h - 1)
=> NatRepr p
-> Compose3 m ((,) b) (Vector' a) p
diff --git a/src/Data/Parameterized/Fin.hs b/src/Data/Parameterized/Fin.hs
index 6118c9d..fcfbfdc 100644
--- a/src/Data/Parameterized/Fin.hs
+++ b/src/Data/Parameterized/Fin.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
{-|
Copyright : (c) Galois, Inc 2021
diff --git a/plots.cabal b/plots.cabal
index 1153d86..18ed2dd 100644
--- a/plots.cabal
+++ b/plots.cabal
@@ -1,5 +1,6 @@
name: plots
version: 0.1.1.2
+x-revision: 1
synopsis: Diagrams based plotting library.
homepage: http://github.com/cchalmers/plots
license: BSD3
@@ -52,17 +53,17 @@ library
colour,
containers >= 0.3 && < 0.7,
data-default >= 0.5 && < 0.8,
- diagrams-core >= 1.3 && < 1.5,
+ diagrams-core >= 1.3 && < 1.6,
diagrams-lib >= 1.3 && < 1.5,
directory,
distributive,
transformers,
filepath,
fingertree,
- hashable >= 1.1 && < 1.3,
- lens >= 4.6 && < 5.0,
+ hashable >= 1.1 && < 1.4,
+ lens >= 4.6 && < 5.1,
linear >= 1.2 && < 2.0,
- monoid-extras >= 0.3 && < 0.6,
+ monoid-extras >= 0.3 && < 0.7,
mtl >= 1.0 && < 3.2,
optparse-applicative,
statistics,
diff --git a/src/Plots/Style.hs b/src/Plots/Style.hs
index 7f33ea5..41a84fc 100644
--- a/src/Plots/Style.hs
+++ b/src/Plots/Style.hs
@@ -529,7 +529,7 @@ instance Each ColourMap ColourMap (Colour Double) (Colour Double) where
each = cmap . each
instance Ixed ColourMap where
- ix = ixColourR
+ ix i = ixColourR i
-- | 'Nothing' == 'transparent'
instance At ColourMap where
diff --git a/snap-core.cabal b/snap-core.cabal
index 75eb5fc..dcd507f 100644
--- a/snap-core.cabal
+++ b/snap-core.cabal
@@ -1,5 +1,6 @@
name: snap-core
version: 1.0.4.2
+x-revision: 1
synopsis: Snap: A Haskell Web Framework (core interfaces and types)
description:
@@ -131,9 +132,9 @@ Library
build-depends:
HUnit >= 1.2 && < 2,
- attoparsec >= 0.12 && < 0.14,
+ attoparsec >= 0.12 && < 0.15,
base >= 4 && < 5,
- bytestring >= 0.9 && < 0.11,
+ bytestring >= 0.9 && < 0.12,
bytestring-builder >= 0.10.4 && < 0.11,
case-insensitive >= 1.1 && < 1.3,
containers >= 0.3 && < 1.0,
@@ -184,7 +185,7 @@ Library
if impl(ghc >= 8.0)
ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
else
- build-depends: fail == 4.9.*, semigroups == 0.18.*
+ build-depends: fail == 4.9.*, semigroups >= 0.18 && < 0.20
if flag(network-uri)
-- Leaving network-uri-2.7.0.0 out for now because it is marked deprecated
@@ -291,7 +292,7 @@ Test-suite testsuite
if impl(ghc >= 8.0)
ghc-options: -Wcompat -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances
else
- build-depends: fail == 4.9.*, semigroups == 0.18.*
+ build-depends: fail == 4.9.*, semigroups >= 0.18 && < 0.20
other-extensions:
BangPatterns,
diff --git a/src/Snap/Internal/Parsing.hs b/src/Snap/Internal/Parsing.hs
index a43aeba..c6676cc 100644
--- a/src/Snap/Internal/Parsing.hs
+++ b/src/Snap/Internal/Parsing.hs
@@ -27,7 +27,11 @@ import qualified Data.Map as Map (empty, insertWith, toL
import Data.Maybe (Maybe (..), maybe)
import Data.Monoid (Monoid (mconcat, mempty), (<>))
import Data.Word (Word8)
+#if MIN_VERSION_base(4,16,0)
+import GHC.Exts (Int (I#), uncheckedShiftRLWord8#, word2Int#, word8ToWord#)
+#else
import GHC.Exts (Int (I#), uncheckedShiftRL#, word2Int#)
+#endif
import GHC.Word (Word8 (..))
import Prelude (Bool (..), Either (..), Enum (fromEnum, toEnum), Eq (..), Num (..), Ord (..), String, and, any, concatMap, elem, error, filter, flip, foldr, fst, id, map, not, otherwise, show, snd, ($), ($!), (&&), (++), (.), (||))
import Snap.Internal.Http.Types (Cookie (Cookie))
@@ -436,7 +440,12 @@ hexd c0 = char8 '%' <> word8 hi <> word8 low
!low = toDigit $ fromEnum $ c .&. 0xf
!hi = toDigit $ (c .&. 0xf0) `shiftr` 4
+#if MIN_VERSION_base(4,16,0)
+ shiftr (W8# a#) (I# b#) = I# (word2Int# (word8ToWord# (uncheckedShiftRLWord8# a# b#)))
+#else
shiftr (W8# a#) (I# b#) = I# (word2Int# (uncheckedShiftRL# a# b#))
+#endif
+
------------------------------------------------------------------------------
diff --git a/src/Streamly/Internal/Control/Concurrent.hs b/src/Streamly/Internal/Control/Concurrent.hs
index 1457cf6..64a9cea 100644
--- a/src/Streamly/Internal/Control/Concurrent.hs
+++ b/src/Streamly/Internal/Control/Concurrent.hs
@@ -31,6 +31,10 @@ import GHC.Exts
import GHC.IO (IO(..))
import System.Mem.Weak (addFinalizer)
+#if __GLASGOW_HASKELL__ >= 903
+import GHC.IO (unIO)
+#endif
+
-- /Since: 0.8.0 ("Streamly.Prelude")/
--
-- | A monad that can perform concurrent or parallel IO operations. Streams
@@ -62,7 +66,13 @@ captureMonadState = control $ \run -> run (return $ RunInIO run)
{-# INLINE rawForkIO #-}
rawForkIO :: IO () -> IO ThreadId
rawForkIO action = IO $ \ s ->
- case fork# action s of (# s1, tid #) -> (# s1, ThreadId tid #)
+ case fork#
+#if __GLASGOW_HASKELL__ >= 903
+ (unIO action)
+#else
+ action
+#endif
+ s of (# s1, tid #) -> (# s1, ThreadId tid #)
-- | Fork a thread to run the given computation, installing the provided
-- exception handler. Lifted to any monad with 'MonadBaseControl IO m'
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment