io-sim 1.4.0.0 → 1.4.1.0

raw patch · 8 files changed

+177/−13 lines, 8 filesdep +primitivedep ~io-classesPVP ok

version bump matches the API change (PVP)

Dependencies added: primitive

Dependency ranges changed: io-classes

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• io-sim.cabal +3/−2
• src/Control/Monad/IOSim.hs +86/−7
• src/Control/Monad/IOSim/Internal.hs +4/−2
• src/Control/Monad/IOSim/Types.hs +11/−0
• src/Control/Monad/IOSimPOR/Internal.hs +4/−2
• test/Test/Control/Monad/IOSim.hs +29/−0
• test/Test/Control/Monad/IOSimPOR.hs +30/−0

@@ -1,5 +1,15 @@ # Revsion history of io-sim +## 1.4.1.0++### Non-breaking changes++* QuickCheck monadic combinators: `monadicIOSim`, `monadicIOSim_` and `runIOSimGen` (#140).+* New dependency on `primitive`+* Provides an instance for `PrimMonad`, giving access to most functionality+  from the `primitive` package (#141).+* Prevented STM waking up threads blocked on `threadDelay` (#142).+ ## 1.4.0.0  ### Breaking changes

@@ -1,6 +1,6 @@ cabal-version:       3.0 name:                io-sim-version:             1.4.0.0+version:             1.4.1.0 synopsis:            A pure simulator for monadic concurrency with STM. description:   A pure simulator monad with support of concurency (base & async style), stm,@@ -76,11 +76,12 @@                        ScopedTypeVariables,                        TypeFamilies   build-depends:       base              >=4.9 && <4.20,-                       io-classes        >=1.3 && <1.5,+                       io-classes       ^>=1.4.1,                        exceptions        >=0.10,                        containers,                        deepseq,                        nothunks,+                       primitive         >=0.7 && <0.10,                        psqueues          >=0.2 && <0.3,                        strict-stm       ^>=1.4,                        si-timers        ^>=1.4,

@@ -1,10 +1,11 @@-{-# LANGUAGE BangPatterns        #-}-{-# LANGUAGE ExplicitNamespaces  #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE BangPatterns          #-}+{-# LANGUAGE ExplicitNamespaces    #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE QuantifiedConstraints #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}  {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}@@ -20,6 +21,10 @@   , Failure (..)   , runSimTrace   , runSimTraceST+    -- *** QuickCheck Monadic combinators+  , monadicIOSim_+  , monadicIOSim+  , runIOSimGen     -- ** Explore races using /IOSimPOR/     -- $iosimpor   , exploreSimTrace@@ -119,6 +124,8 @@ import Control.Monad.IOSimPOR.QuickCheckUtils  import Test.QuickCheck+import Test.QuickCheck.Gen.Unsafe (Capture (..), capture)+import Test.QuickCheck.Monadic (PropertyM, monadic')  import Debug.Trace qualified as Debug import System.IO.Unsafe@@ -751,3 +758,75 @@                 Nothing -> error "compareTraceST: invariant violation"         wakeup _ _ SimTrace {} = error "compareTracesST: invariant violation"         wakeup _ _ fail = return fail++--+-- QuickCheck monadic combinators+--++++-- | Like <monadicST https://hackage.haskell.org/package/QuickCheck-2.14.3/docs/Test-QuickCheck-Monadic.html#v:monadicST>.+--+-- Note: it calls `traceResult` in non-strict mode, e.g. leaked threads do not+-- cause failures.+--+-- @since 1.4.1.0+--+monadicIOSim_ :: Testable a+              => (forall s. PropertyM (IOSim s) a)+              -> Property+monadicIOSim_ sim =+    monadicIOSim+      (\e -> case traceResult False e of+          Left e  -> counterexample (show e) False+          Right p -> p)+      id+      sim++-- | A more general version of `monadicIOSim_`, which:+--+-- * allows to run in monad stacks build on top of `IOSim`;+-- * gives more control how to attach debugging information to failed+--   tests.+--+-- Note, to use this combinator your monad needs to be defined as:+--+-- > newtype M s a = M s { runM :: ReaderT State (IOSim s) a }+--+-- It's important that `M s` is a monad.  For such a monad one you'll need provide+-- a natural transformation:+-- @+--   -- the state could also be created as an `IOSim` computation.+--   nat :: forall s a. State -> M s a -> 'IOSim' s a+--   nat state m = runStateT (runM m) state+-- @+--+-- @since 1.4.1.0+--+monadicIOSim :: (Testable a, forall s. Monad (m s))+             => (SimTrace Property -> Property)+             -- ^ Allows to trace `SimTrace` in counterexamples.  The simplest+             -- use case is to pass:+             --+             -- > either (\e -> counterexample (show e) False) id . traceResult False+             --+             -- as `monadicIOSim_` does.+             --+             -> (forall s a. m s a -> IOSim s a)+             -- ^ natural transformation from `m` to @IOSim` s@+             -> (forall s. PropertyM (m s) a)+             -> Property+monadicIOSim f tr sim = property (runIOSimGen f (tr <$> monadic' sim))++-- | Like <runSTGen+-- https://hackage.haskell.org/package/QuickCheck-2.14.3/docs/Test-QuickCheck-Monadic.html#v:runSTGen>.+--+-- @since 1.4.1.0+--+runIOSimGen :: (SimTrace a -> Property)+            -> (forall s. Gen (IOSim s a))+            -> Gen Property+runIOSimGen f sim = do+    Capture eval <- capture+    let trace = runSimTrace (eval sim)+    return (f trace)

@@ -747,8 +747,10 @@              -- Check all fired threadDelays         let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ]-            wakeup            = fst `fmap` wakeupThreadDelay ++ wakeupSTM-            (_, !simstate')   = unblockThreads False wakeup simstate+            !simstate'        =+                snd . unblockThreads False (fst `fmap` wakeupThreadDelay)+              . snd . unblockThreads True  wakeupSTM+              $ simstate              -- For each 'timeout' action where the timeout has fired, start a             -- new thread to execute throwTo to interrupt the action.

@@ -102,6 +102,7 @@ import Control.Monad.Class.MonadTimer import Control.Monad.Class.MonadTimer.SI (TimeoutState (..)) import Control.Monad.Class.MonadTimer.SI qualified as SI+import Control.Monad.Primitive qualified as Prim import Control.Monad.ST.Lazy import Control.Monad.ST.Strict qualified as StrictST import Control.Monad.ST.Unsafe (unsafeSTToIO)@@ -633,7 +634,17 @@   asyncWithUnmask k = async (k unblock)   asyncOnWithUnmask _ k = async (k unblock) +-- | This provides access to (almost) everything from the+-- @primitive@ package, but don't try to use the @MVar@s as that will not+-- work as expected.+--+-- @since 1.4.1.0+instance Prim.PrimMonad (IOSim s) where+  type PrimState (IOSim s) = s+  primitive st = IOSim $ oneShot $ \k -> LiftST (Prim.primitive st) k+ instance MonadST (IOSim s) where+  stToIO f = IOSim $ oneShot $ \k -> LiftST f k   withLiftST f = f liftST  -- | Lift an 'StrictST.ST' computation to 'IOSim'.

@@ -1033,9 +1033,11 @@         mapM_ (\(SomeTVar tvar) -> unblockAllThreadsFromTVar tvar) written          let wakeupThreadDelay = [ (tid, tmid) | TimerThreadDelay tid tmid <- fired ]-            wakeup            = fst `fmap` wakeupThreadDelay ++ wakeupSTM             -- TODO: the vector clock below cannot be right, can it?-            (_, !simstate')   = unblockThreads False bottomVClock wakeup simstate+            !simstate'        =+                snd . unblockThreads False bottomVClock (fst `fmap` wakeupThreadDelay)+              . snd . unblockThreads True  bottomVClock wakeupSTM+              $ simstate              -- For each 'timeout' action where the timeout has fired, start a             -- new thread to execute throwTo to interrupt the action.

@@ -68,6 +68,7 @@     , testProperty "async exceptions 2"     unit_timeouts_and_async_exceptions_2     , testProperty "async exceptions 3"     unit_timeouts_and_async_exceptions_3     , testProperty "threadDelay and STM"    unit_threadDelay_and_stm+    , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay     , testProperty "throwTo and STM"        unit_throwTo_and_stm     ]   , testProperty "threadId order (IOSim)"   (withMaxSuccess 1000 prop_threadId_order_order_Sim)@@ -1159,6 +1160,34 @@        return (t1 `diffTime` t0 === delay) +unit_registerDelay_threadDelay :: Property+unit_registerDelay_threadDelay =+    let trace = runSimTrace experiment in+        counterexample (ppTrace_ trace)+      . either (\e -> counterexample (show e) False) id+      . traceResult False+      $ trace+  where+    experiment :: IOSim s Property+    experiment = do+      v0 <- registerDelay 2+      v1 <- newTVarIO False++      _ <- forkIO $ do+        threadDelay 1+        atomically $ writeTVar v1 True++      atomically $ do+        b0 <- LazySTM.readTVar v0+        b1 <- readTVar v1+        check $ b0 || b1++      let delay = 2+      t0 <- getMonotonicTime+      threadDelay delay+      t1 <- getMonotonicTime++      return (t1 `diffTime` t0 === delay)  -- | Verify that a thread blocked on `throwTo` is not unblocked by an STM -- transaction.

@@ -70,6 +70,7 @@       , testProperty "timeout"                prop_timeout       , testProperty "timeouts"               prop_timeouts       , testProperty "stacked timeouts"       prop_stacked_timeouts+      , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay       ]     , testProperty "threadId order (IOSim)"   (withMaxSuccess 1000 prop_threadId_order_order_Sim)     , testProperty "forkIO order (IOSim)"     (withMaxSuccess 1000 prop_fork_order_ST)@@ -969,6 +970,35 @@                | otherwise -- i.e. timeout0 >= timeout1               = Just Nothing++unit_registerDelay_threadDelay :: Property+unit_registerDelay_threadDelay =+    exploreSimTrace id experiment $ \_ trace ->+        counterexample (ppTrace_ trace)+      . either (\e -> counterexample (show e) False) id+      . traceResult False+      $ trace+  where+    experiment :: IOSim s Property+    experiment = do+      v0 <- registerDelay 2+      v1 <- newTVarIO False++      _ <- forkIO $ do+        threadDelay 1+        atomically $ writeTVar v1 True++      atomically $ do+        b0 <- readTVar v0+        b1 <- readTVar v1+        check $ b0 || b1++      let delay = 2+      t0 <- getMonotonicTime+      threadDelay delay+      t1 <- getMonotonicTime++      return (t1 `diffTime` t0 === delay)  unit_timeouts_and_async_exceptions_1 :: Property unit_timeouts_and_async_exceptions_1 =