Merge pull request #301 from barrucadu/msw/nightly-2019-10-02

Support GHC 8.8

.travis.yml

@@ -49,6 +49,9 @@ jobs:
   - stage: test
     if: type != pull_request
     env: MODE=test RESOLVER=lts-13.3 STACKVER=1.9.3 # GHC 8.6 - .3 because hedgehog and stylish-haskell aren't in .0
+  - stage: test
+    if: type != pull_request
+    env: MODE=test RESOLVER=nightly-2019-10-02 STACKVER=2.1.3 # GHC 8.8 - no lts yet
   - stage: test
     if: type != pull_request
     env: MODE=test RESOLVER=nightly

README.markdown

@@ -45,8 +45,8 @@ There are a few different packages under the Déjà Fu umbrella:
 
 |   | Version | Summary |
 | - | ------- | ------- |
-| [concurrency][h:conc]    | 1.7.0.0  | Typeclasses, functions, and data types for concurrency and STM. |
-| [dejafu][h:dejafu]       | 2.1.0.0  | Systematic testing for Haskell concurrency. |
+| [concurrency][h:conc]    | 1.8.0.0  | Typeclasses, functions, and data types for concurrency and STM. |
+| [dejafu][h:dejafu]       | 2.1.0.1  | Systematic testing for Haskell concurrency. |
 | [hunit-dejafu][h:hunit]  | 2.0.0.1  | Deja Fu support for the HUnit test framework. |
 | [tasty-dejafu][h:tasty]  | 2.0.0.1  | Deja Fu support for the Tasty test framework. |
 

concurrency/CHANGELOG.rst

@@ -7,6 +7,31 @@ standard Haskell versioning scheme.
 .. _PVP: https://pvp.haskell.org/
 
 
+1.8.0.0 (2019-10-04)
+--------------------
+
+* Git: :tag:`concurrency-1.8.0.0`
+* Hackage: :hackage:`concurrency-1.8.0.0`
+
+Added
+~~~~~
+
+* ``MonadFail`` instances for ``Control.Monad.Conc.Class.IsConc`` and
+  ``Control.Monad.STM.IsSTM``.
+
+Changed
+~~~~~~~
+
+* Added ``MonadFail`` constraints to
+  ``Control.Concurrent.Classy.QSem.newQSem`` and
+  ``Control.Concurrent.Classy.QSemN.newQSemN``.
+
+Miscellaneous
+~~~~~~~~~~~~~
+
+* Fixed a compilation error with GHC 8.8
+
+
 1.7.0.0 (2019-03-24)
 --------------------
 

concurrency/Control/Concurrent/Classy/QSem.hs

@@ -17,6 +17,7 @@ module Control.Concurrent.Classy.QSem
 
 import           Control.Concurrent.Classy.QSemN
 import           Control.Monad.Conc.Class        (MonadConc)
+import           Control.Monad.Fail              (MonadFail)
 
 -- | @QSem@ is a quantity semaphore in which the resource is acquired
 -- and released in units of one. It provides guaranteed FIFO ordering
@@ -35,7 +36,7 @@ newtype QSem m = QSem (QSemN m)
 -- quantity must be at least 0.
 --
 -- @since 1.0.0.0
-newQSem :: MonadConc m => Int -> m (QSem m)
+newQSem :: (MonadConc m, MonadFail m) => Int -> m (QSem m)
 newQSem initial
   | initial < 0 = fail "newQSem: Initial quantity mus tbe non-negative."
   | otherwise   = QSem <$> newQSemN initial

concurrency/Control/Concurrent/Classy/QSemN.hs

@@ -20,6 +20,7 @@ import           Control.Concurrent.Classy.MVar
 import           Control.Monad.Catch            (mask_, onException,
                                                  uninterruptibleMask_)
 import           Control.Monad.Conc.Class       (MonadConc)
+import           Control.Monad.Fail             (MonadFail)
 import           Data.Maybe
 
 -- | 'QSemN' is a quantity semaphore in which the resource is aqcuired
@@ -39,7 +40,7 @@ newtype QSemN m = QSemN (MVar m (Int, [(Int, MVar m ())], [(Int, MVar m ())]))
 --  The initial quantity must be at least 0.
 --
 -- @since 1.0.0.0
-newQSemN :: MonadConc m => Int -> m (QSemN m)
+newQSemN :: (MonadConc m, MonadFail m) => Int -> m (QSemN m)
 newQSemN initial
   | initial < 0 = fail "newQSemN: Initial quantity must be non-negative"
   | otherwise   = QSemN <$> newMVar (initial, [], [])

concurrency/Control/Monad/Conc/Class.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- |
@@ -12,7 +13,7 @@
 -- License     : MIT
 -- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
 -- Stability   : experimental
--- Portability : CPP, FlexibleContexts, PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies
+-- Portability : CPP, FlexibleContexts, PolyKinds, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TypeFamilies
 --
 -- This module captures in a typeclass the interface of concurrency
 -- monads.
@@ -94,6 +95,7 @@ import           Control.Exception            (AsyncException(ThreadKilled),
 import           Control.Monad.Catch          (MonadCatch, MonadMask,
                                                MonadThrow)
 import qualified Control.Monad.Catch          as Ca
+import           Control.Monad.Fail           (MonadFail(..))
 import           Control.Monad.STM.Class      (IsSTM, MonadSTM, TVar, fromIsSTM,
                                                readTVar)
 import           Control.Monad.Trans.Control  (MonadTransControl, StT, liftWith)
@@ -791,6 +793,9 @@ labelMe n  = do
 newtype IsConc m a = IsConc { unIsConc :: m a }
   deriving (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask)
 
+-- | @since 1.8.0.0
+deriving instance MonadFail m => MonadFail (IsConc m)
+
 -- | Wrap an @m a@ value inside an @IsConc@ if @m@ has a @MonadConc@
 -- instance.
 --

concurrency/Control/Monad/STM/Class.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- |
@@ -9,7 +10,7 @@
 -- License     : MIT
 -- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
 -- Stability   : experimental
--- Portability : CPP, RankNTypes, TemplateHaskell, TypeFamilies
+-- Portability : CPP, RankNTypes, StandaloneDeriving, TemplateHaskell, TypeFamilies
 --
 -- This module provides an abstraction over 'STM', which can be used
 -- with 'MonadConc'.
@@ -62,6 +63,7 @@ module Control.Monad.STM.Class
 import           Control.Applicative          (Alternative(..))
 import           Control.Exception            (Exception)
 import           Control.Monad                (MonadPlus(..), unless)
+import           Control.Monad.Fail           (MonadFail(..))
 import           Control.Monad.Reader         (ReaderT)
 import           Control.Monad.Trans          (lift)
 import           Control.Monad.Trans.Identity (IdentityT)
@@ -185,6 +187,9 @@ instance MonadSTM STM.STM where
 newtype IsSTM m a = IsSTM { unIsSTM :: m a }
   deriving (Functor, Applicative, Alternative, Monad, MonadPlus, Ca.MonadThrow, Ca.MonadCatch)
 
+-- | @since 1.8.0.0
+deriving instance MonadFail m => MonadFail (IsSTM m)
+
 -- | Wrap an @m a@ value inside an @IsSTM@ if @m@ has a @MonadSTM@
 -- instance.
 --

concurrency/concurrency.cabal

@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                concurrency
-version:             1.7.0.0
+version:             1.8.0.0
 synopsis:            Typeclasses, functions, and data types for concurrency and STM.
 
 description:
@@ -32,7 +32,7 @@ source-repository head
 source-repository this
   type:     git
   location: https://github.com/barrucadu/dejafu.git
-  tag:      concurrency-1.7.0.0
+  tag:      concurrency-1.8.0.0
 
 library
   exposed-modules:     Control.Monad.Conc.Class

dejafu-tests/lib/Examples/SearchParty.hs

@@ -19,6 +19,7 @@ import           Control.Concurrent.Classy.STM.TMVar (TMVar, isEmptyTMVar,
                                                       tryTakeTMVar)
 import           Control.Monad                       (unless, when)
 import           Control.Monad.Conc.Class
+import qualified Control.Monad.Fail                  as F
 import           Control.Monad.STM.Class
 import           Data.Functor                        (void)
 import           Data.Maybe                          (fromJust, isNothing)
@@ -91,15 +92,16 @@ instance MonadConc m => Applicative (Find m) where
 instance MonadConc m => Monad (Find m) where
   return = pure
 
-  fail _ = Find $ workItem' Nothing
-
   (Find mf) >>= g = Find $ do
     f   <- mf
     res <- result f
 
-    case res of
-      Just a  -> unFind $ g a
-      Nothing -> fail ""
+    unFind $ case res of
+      Just a  -> g a
+      Nothing -> F.fail ""
+
+instance MonadConc m => F.MonadFail (Find m) where
+    fail _ = Find $ workItem' Nothing
 
 --------------------------------------------------------------------------------
 -- Execution

dejafu-tests/lib/Integration/SingleThreaded.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE FlexibleContexts #-}
+
 module Integration.SingleThreaded where
 
 import           Control.Exception         (ArithException(..),
@@ -12,6 +14,7 @@ import           Test.DejaFu               (Condition(..), gives, gives',
 import           Control.Concurrent.Classy
 import           Control.Monad             (replicateM_, when)
 import           Control.Monad.Catch       (throwM)
+import           Control.Monad.Fail        (MonadFail)
 import           Control.Monad.IO.Class    (liftIO)
 import qualified Data.IORef                as IORef
 import           Data.Maybe                (isNothing)
@@ -167,7 +170,7 @@ stmTests = toTestList
       (6==) <$> readTVarConc ctv
 
   , djfu "MonadSTM is a MonadFail" (alwaysFailsWith isUncaughtException)
-      (atomically $ fail "hello world" :: MonadConc m => m ())  -- avoid an ambiguous type
+      (atomically $ fail "hello world" :: (MonadConc m, MonadFail (STM m)) => m ())  -- avoid an ambiguous type
 
   , djfu "'retry' is not caught by 'catch'" (gives' [True]) $
       atomically
@@ -226,7 +229,7 @@ exceptionTests = toTestList
       catchArithException (throwTo tid Overflow >> pure False) (\_ -> pure True)
 
   , djfu "MonadConc is a MonadFail" (alwaysFailsWith isUncaughtException)
-      (fail "hello world" :: MonadConc m => m ())  -- avoid an ambiguous type
+      (fail "hello world" :: (MonadConc m, MonadFail m) => m ())  -- avoid an ambiguous type
   ]
 
 --------------------------------------------------------------------------------

dejafu-tests/lib/QSemN.hs

@@ -5,11 +5,12 @@ import           Control.Concurrent.Classy.MVar
 import           Control.Monad.Catch            (mask_, onException,
                                                  uninterruptibleMask_)
 import           Control.Monad.Conc.Class       (MonadConc)
+import           Control.Monad.Fail             (MonadFail)
 import           Data.Maybe
 
 newtype QSemN m = QSemN (MVar m (Int, [(Int, MVar m ())], [(Int, MVar m ())]))
 
-newQSemN :: MonadConc m => Int -> m (QSemN m)
+newQSemN :: (MonadConc m, MonadFail m) => Int -> m (QSemN m)
 newQSemN initial
   | initial < 0 = fail "newQSemN: Initial quantity must be non-negative"
   | otherwise   = QSemN <$> newMVar (initial, [], [])

dejafu-tests/lib/Test/Tasty/Hedgehog.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 {-
@@ -159,13 +160,21 @@ instance IsOption HedgehogShrinkRetries where
   optionName = pure "hedgehog-retries"
   optionHelp = pure "Number of times to re-run a test during shrinking"
 
+getReport :: Report a -> (TestCount, a)
+#if MIN_VERSION_hedgehog(1,0,0)
+getReport (Report testCount _ _ status) = (testCount, status)
+#else
+getReport (Report testCount _ status) = (testCount, status)
+#endif
+
 reportToProgress :: Int
                  -> Int
                  -> Int
                  -> Report Progress
                  -> T.Progress
-reportToProgress testLimit _ shrinkLimit (Report testsDone _ status) =
+reportToProgress testLimit _ shrinkLimit report =
   let
+    (testsDone, status) = getReport report
     ratio x y = 1.0 * fromIntegral x / fromIntegral y
   in
     -- TODO add details for tests run / discarded / shrunk
@@ -180,7 +189,8 @@ reportOutput :: Bool
              -> String
              -> Report Result
              -> IO String
-reportOutput _ showReplay name report@(Report _ _ status) = do
+reportOutput _ showReplay name report = do
+  let (_, status) = getReport report
   -- TODO add details for tests run / discarded / shrunk
   s <- renderResult Nothing (Just (PropertyName name)) report
   pure $ case status of

dejafu-tests/lib/Unit/Properties.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 module Unit.Properties where
 

dejafu/CHANGELOG.rst

@@ -7,6 +7,19 @@ standard Haskell versioning scheme.
 .. _PVP: https://pvp.haskell.org/
 
 
+2.1.0.1 (2019-10-04)
+--------------------
+
+* Git: :tag:`dejafu-2.1.0.1`
+* Hackage: :hackage:`dejafu-2.1.0.1`
+
+Miscellaneous
+~~~~~~~~~~~~~
+
+* Fixed a compilation error with GHC 8.8
+* The upper version bound on :hackage:`concurrency` is <1.9.
+
+
 2.1.0.0 (2019-03-24)
 --------------------
 

dejafu/Test/DejaFu/Conc/Internal/Common.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
@@ -8,7 +9,7 @@
 -- License     : MIT
 -- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
 -- Stability   : experimental
--- Portability : ExistentialQuantification, GADTs, RankNTypes
+-- Portability : CPP, ExistentialQuantification, GADTs, RankNTypes
 --
 -- Common types and utility functions for deterministic execution of
 -- 'MonadConc' implementations. This module is NOT considered to form
@@ -95,9 +96,13 @@ instance (pty ~ Basic) => Applicative (Program pty n) where
 
 instance (pty ~ Basic) => Monad (Program pty n) where
   return  = pure
-  fail    = Fail.fail
   m >>= k = ModelConc $ \c -> runModelConc m (\x -> runModelConc (k x) c)
 
+#if MIN_VERSION_base(4,13,0)
+#else
+  fail = Fail.fail
+#endif
+
 instance (pty ~ Basic) => Fail.MonadFail (Program pty n) where
   fail e = ModelConc $ \_ -> AThrow (MonadFailException e)
 
@@ -243,9 +248,13 @@ instance Applicative (Invariant n) where
 
 instance Monad (Invariant n) where
   return  = pure
-  fail    = Fail.fail
   m >>= k = Invariant $ \c -> runInvariant m (\x -> runInvariant (k x) c)
 
+#if MIN_VERSION_base(4,13,0)
+#else
+  fail = Fail.fail
+#endif
+
 instance Fail.MonadFail (Invariant n) where
   fail e = Invariant $ \_ -> IThrow (MonadFailException e)
 

dejafu/Test/DejaFu/Conc/Internal/STM.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -11,7 +12,7 @@
 -- License     : MIT
 -- Maintainer  : Michael Walker <mike@barrucadu.co.uk>
 -- Stability   : experimental
--- Portability : ExistentialQuantification, NoMonoLocalBinds, RecordWildCards, TypeFamilies
+-- Portability : CPP, ExistentialQuantification, NoMonoLocalBinds, RecordWildCards, TypeFamilies
 --
 -- 'MonadSTM' testing implementation, internal types and definitions.
 -- This module is NOT considered to form part of the public interface
@@ -51,7 +52,10 @@ instance Monad (ModelSTM n) where
     return  = pure
     m >>= k = ModelSTM $ \c -> runModelSTM m (\x -> runModelSTM (k x) c)
 
+#if MIN_VERSION_base(4,13,0)
+#else
     fail = Fail.fail
+#endif
 
 instance Fail.MonadFail (ModelSTM n) where
     fail e = ModelSTM $ \_ -> SThrow (MonadFailException e)