monad-schedule 0.1.2.1 → 0.1.2.2
raw patch · 11 files changed
+434/−355 lines, 11 filesdep ~HUnitdep ~QuickCheckdep ~base
Dependency ranges changed: HUnit, QuickCheck, base, free, stm, test-framework, test-framework-hunit, test-framework-quickcheck2, time-domain, transformers
Files
- CHANGELOG.md +4/−0
- monad-schedule.cabal +54/−38
- src/Control/Monad/Schedule/Class.hs +106/−96
- src/Control/Monad/Schedule/OSThreadPool.hs +19/−18
- src/Control/Monad/Schedule/RoundRobin.hs +8/−6
- src/Control/Monad/Schedule/Sequence.hs +8/−6
- src/Control/Monad/Schedule/Trans.hs +67/−62
- src/Control/Monad/Schedule/Yield.hs +9/−7
- test/Main.hs +1/−3
- test/Trans.hs +91/−61
- test/Yield.hs +67/−58
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for monad-schedule +## 0.1.2.2++* Compatibility with GHC 9.8+ ## 0.1.2.0 -- 2022-06-26 * Added test suite
monad-schedule.cabal view
@@ -1,55 +1,71 @@-cabal-version: 2.4-name: monad-schedule-version: 0.1.2.1-license: MIT-license-file: LICENSE-author: Manuel Bärenz-maintainer: programming@manuelbaerenz.de-synopsis: A new, simple, composable concurrency abstraction.-description: A monad @m@ is said to allow scheduling if you can pass a number of actions @m a@ to it,- and those can be executed at the same time concurrently.- You can observe the result of the actions after some time:- Some actions will complete first, and the results of these are returned then as a list @'NonEmpty' a@.- Other actions are still running, and for these you will receive continuations of type @m a@,- which you can further run or schedule to completion as you like.-category: Concurrency+cabal-version: 2.4+name: monad-schedule+version: 0.1.2.2+license: MIT+license-file: LICENSE+author: Manuel Bärenz+maintainer: programming@manuelbaerenz.de+synopsis: A new, simple, composable concurrency abstraction.+description:+ A monad @m@ is said to allow scheduling if you can pass a number of actions @m a@ to it,+ and those can be executed at the same time concurrently.+ You can observe the result of the actions after some time:+ Some actions will complete first, and the results of these are returned then as a list @'NonEmpty' a@.+ Other actions are still running, and for these you will receive continuations of type @m a@,+ which you can further run or schedule to completion as you like. +category: Concurrency+extra-doc-files: CHANGELOG.md -extra-source-files: CHANGELOG.md+tested-with:+ GHC == 8.8.4+ GHC == 8.10.7+ GHC == 9.0.2+ GHC == 9.2.5+ GHC == 9.4.5+ GHC == 9.6.2+ GHC == 9.8.1 +source-repository head+ type: git+ location: https://github.com/turion/monad-schedule+ common deps build-depends:- , base >= 4.13.0 && <= 4.19- , stm >= 2.5- , transformers >= 0.5- , free >= 5.1- , time-domain >= 0.1+ , base >=4.13.0 && <4.20.0+ , free >=5.1 && < 5.3+ , stm ^>=2.5+ , time-domain ^>=0.1+ , transformers >=0.5 && < 0.7 library- import: deps+ import: deps exposed-modules:- Control.Monad.Schedule.Class- Control.Monad.Schedule.OSThreadPool- Control.Monad.Schedule.RoundRobin- Control.Monad.Schedule.Sequence- Control.Monad.Schedule.Trans- Control.Monad.Schedule.Yield+ Control.Monad.Schedule.Class+ Control.Monad.Schedule.OSThreadPool+ Control.Monad.Schedule.RoundRobin+ Control.Monad.Schedule.Sequence+ Control.Monad.Schedule.Trans+ Control.Monad.Schedule.Yield+ hs-source-dirs: src default-language: Haskell2010 test-suite test- import: deps- type: exitcode-stdio-1.0- main-is: Main.hs+ import: deps+ type: exitcode-stdio-1.0+ main-is: Main.hs other-modules: Trans Yield- hs-source-dirs: test++ hs-source-dirs: test build-depends:- , test-framework >= 0.8- , test-framework-quickcheck2 >= 0.3- , test-framework-hunit >= 0.3- , HUnit >= 1.3- , QuickCheck >= 2.12+ , HUnit ^>=1.6 , monad-schedule- default-language: Haskell2010+ , QuickCheck ^>=2.14+ , test-framework ^>=0.8+ , test-framework-hunit ^>=0.3+ , test-framework-quickcheck2 ^>=0.3++ default-language: Haskell2010
src/Control/Monad/Schedule/Class.hs view
@@ -3,16 +3,12 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-module Control.Monad.Schedule.Class where +module Control.Monad.Schedule.Class where -- base import Control.Arrow@@ -25,12 +21,11 @@ import Data.Functor.Identity import Data.Kind (Type) import Data.List.NonEmpty hiding (length)+import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (fromJust) import Data.Void-import Prelude hiding (map, zip) import Unsafe.Coerce (unsafeCoerce)--import qualified Data.List.NonEmpty as NonEmpty+import Prelude hiding (map, zip) -- transformers import Control.Monad.Trans.Accum@@ -66,9 +61,10 @@ -- together with completions for the unfinished actions. schedule :: NonEmpty (m a) -> m (NonEmpty a, [m a]) --- | Keeps 'schedule'ing actions until all are finished.--- Returns the same set of values as 'sequence',--- but utilises concurrency and may thus change the order of the values.+{- | Keeps 'schedule'ing actions until all are finished.+ Returns the same set of values as 'sequence',+ but utilises concurrency and may thus change the order of the values.+-} scheduleAndFinish :: (Monad m, MonadSchedule m) => NonEmpty (m a) -> m (NonEmpty a) scheduleAndFinish actions = do (finishedFirst, running) <- schedule actions@@ -78,23 +74,24 @@ finishedLater <- scheduleAndFinish $ a :| as return $ finishedFirst <> finishedLater --- | Uses 'scheduleAndFinish' to execute all actions concurrently,--- then orders them again.--- Thus it behaves semantically like 'sequence',--- but leverages concurrency.+{- | Uses 'scheduleAndFinish' to execute all actions concurrently,+ then orders them again.+ Thus it behaves semantically like 'sequence',+ but leverages concurrency.+-} sequenceScheduling :: (Monad m, MonadSchedule m) => NonEmpty (m a) -> m (NonEmpty a)-sequenceScheduling- = zip [1..]- >>> map strength- >>> scheduleAndFinish- >>> fmap (sortWith fst >>> map snd)+sequenceScheduling =+ zip [1 ..]+ >>> map strength+ >>> scheduleAndFinish+ >>> fmap (sortWith fst >>> map snd) where- strength :: Functor m => (a, m b) -> m (a, b)- strength (a, mb) = (a, ) <$> mb+ strength :: (Functor m) => (a, m b) -> m (a, b)+ strength (a, mb) = (a,) <$> mb -- | When there are no effects, return all values immediately instance MonadSchedule Identity where- schedule as = ( , []) <$> sequence as+ schedule as = (,[]) <$> sequence as {- | Fork all actions concurrently in separate threads and wait for the first one to complete.@@ -114,103 +111,112 @@ as' <- drain var let remaining = replicate (length as - 1 - length as') $ takeMVar var return (a :| as', remaining)- where- drain :: MVar a -> IO [a]- drain var = do- aMaybe <- tryTakeMVar var- case aMaybe of- Just a -> do- as' <- drain var- return $ a : as'- Nothing -> return []+ where+ drain :: MVar a -> IO [a]+ drain var = do+ aMaybe <- tryTakeMVar var+ case aMaybe of+ Just a -> do+ as' <- drain var+ return $ a : as'+ Nothing -> return [] -- TODO Needs dependency -- instance MonadSchedule STM where -- | Pass through the scheduling functionality of the underlying monad instance (Functor m, MonadSchedule m) => MonadSchedule (IdentityT m) where- schedule- = fmap runIdentityT- >>> schedule- >>> fmap (fmap (fmap IdentityT))- >>> IdentityT+ schedule =+ fmap runIdentityT+ >>> schedule+ >>> fmap (fmap (fmap IdentityT))+ >>> IdentityT --- | Write in the order of scheduling:--- The first actions to return write first.+{- | Write in the order of scheduling:+ The first actions to return write first.+-} instance (Monoid w, Functor m, MonadSchedule m) => MonadSchedule (LazyWriter.WriterT w m) where- schedule = fmap LazyWriter.runWriterT- >>> schedule- >>> fmap (first (fmap fst &&& (fmap snd >>> fold)) >>> assoc >>> first (second $ fmap LazyWriter.WriterT))- >>> LazyWriter.WriterT+ schedule =+ fmap LazyWriter.runWriterT+ >>> schedule+ >>> fmap (first (fmap fst &&& (fmap snd >>> fold)) >>> assoc >>> first (second $ fmap LazyWriter.WriterT))+ >>> LazyWriter.WriterT where assoc :: ((a, w), c) -> ((a, c), w) assoc ((a, w), c) = ((a, c), w) --- | Write in the order of scheduling:--- The first actions to return write first.+{- | Write in the order of scheduling:+ The first actions to return write first.+-} instance (Monoid w, Functor m, MonadSchedule m) => MonadSchedule (StrictWriter.WriterT w m) where- schedule = fmap StrictWriter.runWriterT- >>> schedule- >>> fmap (first (fmap fst &&& (fmap snd >>> fold)) >>> assoc >>> first (second $ fmap StrictWriter.WriterT))- >>> StrictWriter.WriterT+ schedule =+ fmap StrictWriter.runWriterT+ >>> schedule+ >>> fmap (first (fmap fst &&& (fmap snd >>> fold)) >>> assoc >>> first (second $ fmap StrictWriter.WriterT))+ >>> StrictWriter.WriterT where assoc :: ((a, w), c) -> ((a, c), w) assoc ((a, w), c) = ((a, c), w) --- | Write in the order of scheduling:--- The first actions to return write first.+{- | Write in the order of scheduling:+ The first actions to return write first.+-} instance (Monoid w, Functor m, MonadSchedule m) => MonadSchedule (CPSWriter.WriterT w m) where- schedule = fmap CPSWriter.runWriterT- >>> schedule- >>> fmap (first (fmap fst &&& (fmap snd >>> fold)) >>> assoc >>> first (second $ fmap CPSWriter.writerT))- >>> CPSWriter.writerT+ schedule =+ fmap CPSWriter.runWriterT+ >>> schedule+ >>> fmap (first (fmap fst &&& (fmap snd >>> fold)) >>> assoc >>> first (second $ fmap CPSWriter.writerT))+ >>> CPSWriter.writerT where assoc :: ((a, w), c) -> ((a, c), w) assoc ((a, w), c) = ((a, c), w) --- | Broadcast the same environment to all actions.--- The continuations keep this initial environment.+{- | Broadcast the same environment to all actions.+ The continuations keep this initial environment.+-} instance (Monad m, MonadSchedule m) => MonadSchedule (ReaderT r m) where- schedule actions = ReaderT $ \r- -> fmap (`runReaderT` r) actions- & schedule- & fmap (second $ fmap lift)+ schedule actions = ReaderT $ \r ->+ fmap (`runReaderT` r) actions+ & schedule+ & fmap (second $ fmap lift) --- | Combination of 'WriterT' and 'ReaderT'.--- Pass the same initial environment to all actions--- and write to the log in the order of scheduling in @m@.+{- | Combination of 'WriterT' and 'ReaderT'.+ Pass the same initial environment to all actions+ and write to the log in the order of scheduling in @m@.+-} instance (Monoid w, Monad m, MonadSchedule m) => MonadSchedule (AccumT w m) where- schedule actions = AccumT $ \w- -> fmap (`runAccumT` w) actions- & schedule- & fmap collectWritesAndWrap+ schedule actions = AccumT $ \w ->+ fmap (`runAccumT` w) actions+ & schedule+ & fmap collectWritesAndWrap where collectWritesAndWrap ::- Monoid w =>+ (Monoid w) => (NonEmpty (a, w), [m (a, w)]) -> ((NonEmpty a, [AccumT w m a]), w) collectWritesAndWrap (finished, running) = let (as, logs) = NonEmpty.unzip finished- in ((as, AccumT . const <$> running), fold logs)+ in ((as, AccumT . const <$> running), fold logs) --- | Schedule all actions according to @m@ and in case of exceptions--- throw the first exception of the immediately returning actions.+{- | Schedule all actions according to @m@ and in case of exceptions+ throw the first exception of the immediately returning actions.+-} instance (Monad m, MonadSchedule m) => MonadSchedule (ExceptT e m) where- schedule- = fmap runExceptT- >>> schedule- >>> fmap ((sequenceA *** fmap ExceptT) >>> extrudeEither)- >>> ExceptT+ schedule =+ fmap runExceptT+ >>> schedule+ >>> fmap (sequenceA *** fmap ExceptT >>> extrudeEither)+ >>> ExceptT where extrudeEither :: (Either e a, b) -> Either e (a, b)- extrudeEither (ea, b) = (, b) <$> ea+ extrudeEither (ea, b) = (,b) <$> ea instance (Monad m, MonadSchedule m) => MonadSchedule (MaybeT m) where- schedule- = fmap (maybeToExceptT ())- >>> schedule- >>> exceptToMaybeT- >>> fmap (second $ fmap exceptToMaybeT)+ schedule =+ fmap (maybeToExceptT ())+ >>> schedule+ >>> exceptToMaybeT+ >>> fmap (second $ fmap exceptToMaybeT) -- instance (Monad m, MonadSchedule m) => MonadSchedule (ContT r m) where -- schedule actions = ContT $ \scheduler@@ -218,16 +224,18 @@ -- & schedule -- & _ --- | Runs two values in a 'MonadSchedule' concurrently--- and returns the first one that yields a value--- and a continuation for the other value.-race- :: (Monad m, MonadSchedule m)- => m a -> m b- -> m (Either (a, m b) (m a, b))+{- | Runs two values in a 'MonadSchedule' concurrently+ and returns the first one that yields a value+ and a continuation for the other value.+-}+race ::+ (Monad m, MonadSchedule m) =>+ m a ->+ m b ->+ m (Either (a, m b) (m a, b)) race aM bM = recoverResult <$> schedule ((Left <$> aM) :| [Right <$> bM]) where- recoverResult :: Monad m => (NonEmpty (Either a b), [m (Either a b)]) -> Either (a, m b) (m a, b)+ recoverResult :: (Monad m) => (NonEmpty (Either a b), [m (Either a b)]) -> Either (a, m b) (m a, b) recoverResult (Left a :| [], [bM']) = Left (a, fromRight e <$> bM') recoverResult (Right b :| [], [aM']) = Right (fromLeft e <$> aM', b) recoverResult (Left a :| [Right b], []) = Left (a, return b)@@ -236,15 +244,17 @@ e = error "race: Internal error" -- FIXME I should only need Selective+ -- | Runs both schedules concurrently and returns their results at the end.-async- :: (Monad m, MonadSchedule m)- => m a -> m b- -> m (a, b)+async ::+ (Monad m, MonadSchedule m) =>+ m a ->+ m b ->+ m (a, b) async aSched bSched = do ab <- race aSched bSched case ab of- Left (a, bCont) -> do+ Left (a, bCont) -> do b <- bCont return (a, b) Right (aCont, b) -> do
src/Control/Monad/Schedule/OSThreadPool.hs view
@@ -1,29 +1,29 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RecordWildCards #-}+ module Control.Monad.Schedule.OSThreadPool where -- base import Control.Concurrent-import Control.Monad ( void, forM, replicateM )+import Control.Monad (forM, replicateM, void) import Control.Monad.IO.Class-import Data.List.NonEmpty hiding (zip, cycle)+import Data.Either (partitionEithers)+import Data.List.NonEmpty hiding (cycle, zip) import Data.Proxy import GHC.TypeLits import Prelude hiding (take) -- stm+import Control.Concurrent.STM import Control.Concurrent.STM.TChan -- rhine import Control.Monad.Schedule.Class-import Control.Concurrent.STM-import Data.Either (partitionEithers) -newtype OSThreadPool (n :: Nat) a = OSThreadPool { unOSThreadPool :: IO a }+newtype OSThreadPool (n :: Nat) a = OSThreadPool {unOSThreadPool :: IO a} deriving (Functor, Applicative, Monad, MonadIO) data WorkerLink a = WorkerLink@@ -32,10 +32,10 @@ } putJob :: WorkerLink a -> OSThreadPool n a -> IO ()-putJob WorkerLink { .. } OSThreadPool { .. }- = atomically- $ writeTChan jobTChan- $ Just unOSThreadPool+putJob WorkerLink {..} OSThreadPool {..} =+ atomically $+ writeTChan jobTChan $+ Just unOSThreadPool makeWorkerLink :: IO (WorkerLink a) makeWorkerLink = do@@ -50,7 +50,7 @@ atomically $ writeTChan resultTChan result worker void $ forkOS worker- return WorkerLink { .. }+ return WorkerLink {..} proxyForActions :: NonEmpty (OSThreadPool n a) -> Proxy n proxyForActions _ = Proxy@@ -59,8 +59,8 @@ schedule actions = OSThreadPool $ do let n = natVal $ proxyForActions actions workerLinks <- replicateM (fromInteger n) makeWorkerLink- backgroundActions <- forM (zip (cycle workerLinks) (toList actions))- $ \(link, action) -> do+ backgroundActions <- forM (zip (cycle workerLinks) (toList actions)) $+ \(link, action) -> do putJob link action return $ resultTChan link pollPools backgroundActions@@ -72,10 +72,11 @@ (_, []) -> do threadDelay 1000 pollPools chans- (remainingChans, a : as) -> return- ( a :| as- , OSThreadPool . atomically . readTChan <$> remainingChans- )+ (remainingChans, a : as) ->+ return+ ( a :| as+ , OSThreadPool . atomically . readTChan <$> remainingChans+ ) pollPool :: TChan a -> IO (Either (TChan a) a) pollPool chan = maybe (Left chan) Right <$> atomically (tryReadTChan chan)
src/Control/Monad/Schedule/RoundRobin.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+ module Control.Monad.Schedule.RoundRobin where -- base@@ -13,16 +14,17 @@ -- monad-schedule import Control.Monad.Schedule.Class --- | Any monad can be trivially scheduled by executing all actions after each other,--- step by step.-newtype RoundRobinT m a = RoundRobinT { unRoundRobin :: m a }+{- | Any monad can be trivially scheduled by executing all actions after each other,+ step by step.+-}+newtype RoundRobinT m a = RoundRobinT {unRoundRobin :: m a} deriving (Functor, Applicative, Monad, MonadIO) instance MonadTrans RoundRobinT where lift = RoundRobinT -- | Execute only the first action, and leave the others for later, preserving the order.-instance Monad m => MonadSchedule (RoundRobinT m) where- schedule actions = ( , NonEmpty.tail actions) <$> fmap pure (NonEmpty.head actions)+instance (Monad m) => MonadSchedule (RoundRobinT m) where+ schedule actions = (,NonEmpty.tail actions) <$> fmap pure (NonEmpty.head actions) type RoundRobin = RoundRobinT Identity
src/Control/Monad/Schedule/Sequence.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections #-}+ module Control.Monad.Schedule.Sequence where -- base@@ -15,15 +16,16 @@ import Control.Monad.Schedule.Class -- | Any monad can be trivially scheduled by executing all actions sequentially.-newtype SequenceT m a = SequenceT { unSequence :: m a }+newtype SequenceT m a = SequenceT {unSequence :: m a} deriving (Functor, Applicative, Monad, MonadIO) instance MonadTrans SequenceT where lift = SequenceT --- | Execute all actions in sequence and return their result when all of them are done.--- Essentially, this is 'sequenceA'.-instance Monad m => MonadSchedule (SequenceT m) where- schedule = sequenceA >>> fmap (, [])+{- | Execute all actions in sequence and return their result when all of them are done.+ Essentially, this is 'sequenceA'.+-}+instance (Monad m) => MonadSchedule (SequenceT m) where+ schedule = sequenceA >>> fmap (,[]) type Sequence = SequenceT Identity
src/Control/Monad/Schedule/Trans.hs view
@@ -1,25 +1,24 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TupleSections #-}+ {- | This module supplies a general purpose monad transformer that adds a syntactical "delay", or "waiting" side effect. -}--{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE TypeSynonymInstances #-} module Control.Monad.Schedule.Trans where -- base-import Data.Ord (comparing)-import Control.Arrow (Arrow(second))+import Control.Arrow (Arrow (second))+import Control.Category ((>>>)) import Control.Concurrent import qualified Control.Concurrent as C-import Control.Category ((>>>)) import Control.Monad (join) import Data.Functor.Classes import Data.Functor.Identity-import Data.List.NonEmpty as N hiding (partition) import Data.List (partition)+import Data.List.NonEmpty as N hiding (partition)+import Data.Ord (comparing) -- transformers import Control.Monad.IO.Class@@ -41,19 +40,20 @@ -- | A functor implementing a syntactical "waiting" action. data Wait diff a = Wait { getDiff :: diff- -- ^ The duration to wait.+ -- ^ The duration to wait. , awaited :: a- -- ^ The encapsulated value.+ -- ^ The encapsulated value. } deriving (Functor, Eq, Show) -instance Eq diff => Eq1 (Wait diff) where+instance (Eq diff) => Eq1 (Wait diff) where liftEq eq (Wait diff1 a) (Wait diff2 b) = diff1 == diff2 && eq a b --- | Compare by the time difference, regardless of the value.------ Note that this would not give a lawful 'Ord' instance since we do not compare the @a@.-compareWait :: Ord diff => Wait diff a -> Wait diff a -> Ordering+{- | Compare by the time difference, regardless of the value.++ Note that this would not give a lawful 'Ord' instance since we do not compare the @a@.+-}+compareWait :: (Ord diff) => Wait diff a -> Wait diff a -> Ordering compareWait = comparing getDiff -- * 'ScheduleT'@@ -68,25 +68,29 @@ type Schedule diff = ScheduleT diff Identity -- | The side effect that waits for a specified amount.-wait :: Monad m => diff -> ScheduleT diff m ()+wait :: (Monad m) => diff -> ScheduleT diff m () wait diff = FreeT $ return $ Free $ Wait diff $ return () --- | Supply a semantic meaning to 'Wait'.--- For every occurrence of @Wait diff@ in the @ScheduleT diff m a@ value,--- a waiting action is executed, depending on 'diff'.-runScheduleT :: Monad m => (diff -> m ()) -> ScheduleT diff m a -> m a+{- | Supply a semantic meaning to 'Wait'.+ For every occurrence of @Wait diff@ in the @ScheduleT diff m a@ value,+ a waiting action is executed, depending on 'diff'.+-}+runScheduleT :: (Monad m) => (diff -> m ()) -> ScheduleT diff m a -> m a runScheduleT waitAction = iterT $ \(Wait n ma) -> waitAction n >> ma --- | Run a 'ScheduleT' value in a 'MonadIO',--- interpreting the times as milliseconds.-runScheduleIO- :: (MonadIO m, Integral n)- => ScheduleT n m a -> m a+{- | Run a 'ScheduleT' value in a 'MonadIO',+ interpreting the times as milliseconds.+-}+runScheduleIO ::+ (MonadIO m, Integral n) =>+ ScheduleT n m a ->+ m a runScheduleIO = runScheduleT $ liftIO . threadDelay . (* 1000) . fromIntegral --- | Formally execute all waiting actions,--- returning the final value and all moments when the schedule would have waited.-execScheduleT :: Monad m => ScheduleT diff m a -> m (a, [diff])+{- | Formally execute all waiting actions,+ returning the final value and all moments when the schedule would have waited.+-}+execScheduleT :: (Monad m) => ScheduleT diff m a -> m (a, [diff]) execScheduleT action = do free <- runFreeT action case free of@@ -95,15 +99,16 @@ (a, diffs) <- execScheduleT cont return (a, diff : diffs) -instance Ord diff => MonadSchedule (Wait diff) where- schedule waits = let (smallestWait :| waits') = N.sortBy compareWait waits in ((, waits') . pure) <$> smallestWait+instance (Ord diff) => MonadSchedule (Wait diff) where+ schedule waits = let (smallestWait :| waits') = N.sortBy compareWait waits in (,waits') . pure <$> smallestWait isZero :: (Eq diff, TimeDifference diff) => diff -> Bool isZero diff = diff `difference` diff == diff --- | Run each action one step until it is discovered which action(s) are pure, or yield next.--- If there is a pure action, it is returned,--- otherwise all actions are shifted to the time when the earliest action yields.+{- | Run each action one step until it is discovered which action(s) are pure, or yield next.+ If there is a pure action, it is returned,+ otherwise all actions are shifted to the time when the earliest action yields.+-} instance (Ord diff, TimeDifference diff, Monad m, MonadSchedule m) => MonadSchedule (ScheduleT diff m) where schedule actions = do (frees, delayed) <- lift $ schedule $ runFreeT <$> actions@@ -111,30 +116,30 @@ where -- We disregard the inner values @a@ and @b@, -- thus this is not an 'Ord' instance.- compareFreeFWait- :: Ord diff- => FreeF (Wait diff) a b- -> FreeF (Wait diff) a b- -> Ordering+ compareFreeFWait ::+ (Ord diff) =>+ FreeF (Wait diff) a b ->+ FreeF (Wait diff) a b ->+ Ordering compareFreeFWait (Pure _) (Pure _) = EQ compareFreeFWait (Pure _) (Free _) = LT compareFreeFWait (Free _) (Pure _) = GT compareFreeFWait (Free wait1) (Free wait2) = compareWait wait1 wait2 -- Separate pure from free values- partitionFreeF- :: [FreeF f a b]- -> ([a], [f b])+ partitionFreeF ::+ [FreeF f a b] ->+ ([a], [f b]) partitionFreeF [] = ([], [])- partitionFreeF (Pure a : xs) = let (as, fbs) = partitionFreeF xs in (a : as, fbs)+ partitionFreeF (Pure a : xs) = let (as, fbs) = partitionFreeF xs in (a : as, fbs) partitionFreeF (Free fb : xs) = let (as, fbs) = partitionFreeF xs in (as, fb : fbs) -- Shift a waiting action by some duration- shift- :: TimeDifference diff- => diff- -> Wait diff a- -> Wait diff a+ shift ::+ (TimeDifference diff) =>+ diff ->+ Wait diff a ->+ Wait diff a shift diff1 (Wait diff2 a) = Wait (diff2 `difference` diff1) a -- Shift a list of free actions by the duration of the head@@ -142,12 +147,12 @@ -- If the head is pure, return it with the remaining actions, -- otherwise wait the minimum duration, give the continuation of the head, -- and shift the remaining actions by that minimum duration.- shiftListOnce- :: TimeDifference diff- => NonEmpty (FreeF (Wait diff) a b)- -> Either- (NonEmpty a, [Wait diff b]) -- Pure value has completed- (Wait diff (b, [Wait diff b])) -- All values wait+ shiftListOnce ::+ (TimeDifference diff) =>+ NonEmpty (FreeF (Wait diff) a b) ->+ Either+ (NonEmpty a, [Wait diff b]) -- Pure value has completed+ (Wait diff (b, [Wait diff b])) -- All values wait shiftListOnce actions = case partitionFreeF $ toList actions of (a : as, waits) -> Left (a :| as, waits) ([], Wait diff cont : waits) -> Right $ Wait diff (cont, shift diff <$> waits)@@ -155,17 +160,17 @@ -- Repeatedly shift the list by the smallest available waiting duration -- until one action returns as pure. -- Return its result, together with the remaining free actions.- shiftList- :: (TimeDifference diff, Ord diff, Monad m, MonadSchedule m)- => NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a))- -- ^ Actionable- -> [ScheduleT diff m a]- -- ^ Delayed- -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a])+ shiftList ::+ (TimeDifference diff, Ord diff, Monad m, MonadSchedule m) =>+ NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) ->+ -- \^ Actionable+ [ScheduleT diff m a] ->+ -- \^ Delayed+ ScheduleT diff m (NonEmpty a, [ScheduleT diff m a]) -- FIXME Don't I need to shift delayed as well? shiftList actions delayed = case shiftListOnce actions of -- Some actions returned. Wrap up the remaining ones.- Left (as, waits) -> return (as, delayed ++ ((FreeT . return . Free) <$> waits))+ Left (as, waits) -> return (as, delayed ++ (FreeT . return . Free <$> waits)) -- No action has returned. -- Wait the remaining time and start scheduling again. Right (Wait diff (cont, waits)) -> do
src/Control/Monad/Schedule/Yield.hs view
@@ -17,18 +17,20 @@ type Yield = YieldT Identity -- | Let another thread wake up.-yield :: Monad m => YieldT m ()+yield :: (Monad m) => YieldT m () yield = wait () -runYieldT :: Monad m => YieldT m a -> m a+runYieldT :: (Monad m) => YieldT m a -> m a runYieldT = runScheduleT $ const $ return () runYield :: Yield a -> a runYield = runIdentity . runYieldT --- | Run a 'YieldT' value in a 'MonadIO',--- interpreting 'yield's as GHC concurrency yields.-runYieldIO- :: MonadIO m- => YieldT m a -> m a+{- | Run a 'YieldT' value in a 'MonadIO',+ interpreting 'yield's as GHC concurrency yields.+-}+runYieldIO ::+ (MonadIO m) =>+ YieldT m a ->+ m a runYieldIO = runScheduleT $ const $ liftIO Concurrent.yield
test/Main.hs view
@@ -1,7 +1,5 @@-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE RecordWildCards #-}+ -- base import Control.Arrow import Control.Monad
test/Trans.hs view
@@ -1,21 +1,24 @@+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} module Trans where -- base--- base+import Control.Arrow import Control.Monad (forever, void)+import Data.List (sort) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty -- transformers import Control.Monad.Trans.Class-import Control.Monad.Trans.Writer (Writer, tell, runWriter, execWriter)+import Control.Monad.Trans.Writer (Writer, execWriter, runWriter, tell) +-- free+import Control.Monad.Free (_Free)+ -- QuickCheck import Test.QuickCheck import qualified Test.QuickCheck as QuickCheck@@ -26,62 +29,87 @@ -- test-framework-hunit import Test.Framework.Providers.HUnit +-- test-framework-quickcheck2+import Test.Framework.Providers.QuickCheck2 (testProperty)+ -- HUnit import Test.HUnit hiding (Test) -- monad-schedule-import Control.Monad.Schedule.Trans import Control.Monad.Schedule.Class (scheduleAndFinish)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Control.Arrow-import Control.Monad.Free (_Free)+import Control.Monad.Schedule.Trans sampleActions :: NonEmpty (MySchedule ()) sampleActions = [wait 23, wait 42] -tests = testGroup "Trans"- [ testCase "Only leftover time is waited"- $ assertRunsLike sampleActions [Waited 23, Waited (42 - 23)]- , testCase "Scheduling two waits"- $ assertRunsEqual sampleActions (NonEmpty.reverse sampleActions)- , testCase "Different number of waits"- $ assertRunsLike- [ myLog "Thread 1 starts" >> wait 5 >> myLog "Thread 1 action" >> wait 5 >> myLog "Thread 1 done"- , myLog "Thread 2 starts" >> wait 7 >> myLog "Thread 2 done"- ]- [ Log "Thread 1 starts"- , Log "Thread 2 starts"- , Waited 5- , Log "Thread 1 action"- , Waited 2- , Log "Thread 2 done"- , Waited 3- , Log "Thread 1 done"- ]- , testCase "Blocking thread doesn't starve other thread (positive wait times)"- $ assertRunContains- [ forever $ myLog "Busy loop starts" >> wait 1 >> myLog "Busy loop ends"- , myLog "One off thread starts" >> wait 2 >> myLog "One off thread does a thing" >> wait 1 >> myLog "One off thread done"- ]- $ Log "One off thread done"- , testCase "Blocking thread doesn't starve other thread (0 waits)"- $ assertRunContains- [ forever $ myLog "Busy loop starts" >> wait 0 >> myLog "Busy loop ends"- , myLog "One off thread starts" >> wait 0 >> myLog "One off thread does a thing" >> wait 0 >> myLog "One off thread done"- ]- $ Log "One off thread done"- , testProperty "Every thread is eventually woken up"- $ withMaxSuccess 1000- $ \(scripts :: Scripts) (skip :: Positive Int) ->- let steps- -- In principle, every iteration of the whole script, every thread should be woken up, but allow for some extra overhead- = take (3 * sizeScripts scripts + 3)- -- Randomly skip some steps ahead- $ drop (getPositive skip)- $ runMySchedule $ interpretScripts scripts- in counterexample ("steps: " ++ show steps)- $ conjoin $ map (Log >>> (`elem` steps)) $ NonEmpty.toList $ threadNames scripts- ]+tests =+ testGroup+ "Trans"+ [ testCase "Only leftover time is waited" $+ assertRunsLike sampleActions [Waited 23, Waited (42 - 23)]+ , testCase "Scheduling two waits" $+ assertRunsEqual sampleActions (NonEmpty.reverse sampleActions)+ , testCase "Different number of waits" $+ assertRunsLike+ [ myLog "Thread 1 starts" >> wait 5 >> myLog "Thread 1 action" >> wait 5 >> myLog "Thread 1 done"+ , myLog "Thread 2 starts" >> wait 7 >> myLog "Thread 2 done"+ ]+ [ Log "Thread 1 starts"+ , Log "Thread 2 starts"+ , Waited 5+ , Log "Thread 1 action"+ , Waited 2+ , Log "Thread 2 done"+ , Waited 3+ , Log "Thread 1 done"+ ]+ , testCase "Blocking thread doesn't starve other thread (positive wait times)"+ $ assertRunContains+ [ forever $ myLog "Busy loop starts" >> wait 1 >> myLog "Busy loop ends"+ , myLog "One off thread starts" >> wait 2 >> myLog "One off thread does a thing" >> wait 1 >> myLog "One off thread done"+ ]+ $ Log "One off thread done"+ , testCase "Blocking thread doesn't starve other thread (0 waits)"+ $ assertRunContains+ [ forever $ myLog "Busy loop starts" >> wait 0 >> myLog "Busy loop ends"+ , myLog "One off thread starts" >> wait 0 >> myLog "One off thread does a thing" >> wait 0 >> myLog "One off thread done"+ ]+ $ Log "One off thread done"+ , testProperty "Every thread is eventually woken up" $+ withMaxSuccess 1000 $+ \(scripts :: Scripts) (skip :: Positive Int) ->+ let steps =+ -- In principle, every iteration of the whole script, every thread should be woken up, but allow for some extra overhead+ take (3 * sizeScripts scripts + 3)+ -- Randomly skip some steps ahead+ $+ drop (getPositive skip) $+ runMySchedule $+ interpretScripts scripts+ in counterexample ("steps: " ++ show steps) $+ conjoin $+ map (Log >>> (`elem` steps)) $+ NonEmpty.toList $+ threadNames scripts+ , testCase "Regression example from rhine"+ $ assertRunsLike+ (mapM_ wait <$> [[5, 5] :: [Integer], [3, 3, 3]])+ $ Waited+ <$> differences+ [ 3+ , 5+ , 6+ , 9+ , 10+ ]+ , testProperty "Always schedules chronologically" $+ \(waits :: NonEmpty [Positive Integer]) ->+ let individualWaits = fmap getPositive <$> waits+ individualTimes = scanl1 (+) <$> individualWaits+ allWaits = map Waited $ filter (> 0) $ differences $ sort $ concat individualTimes+ program = mapM wait <$> individualWaits+ in runMySchedule program === allWaits+ ] assertRunsEqual :: NonEmpty (MySchedule a1) -> NonEmpty (MySchedule a2) -> Assertion assertRunsEqual actions1 actions2 = assertEqual "Should run the same under scheduling" (runMySchedule actions1) (runMySchedule actions2)@@ -108,37 +136,39 @@ runMySchedule :: NonEmpty (MySchedule a) -> [Event] runMySchedule = execWriter . runScheduleT (tell . pure . Waited) . scheduleAndFinish +differences :: [Integer] -> [Integer]+differences times = uncurry (-) <$> zip times (0 : times)+ data Script = Script { prefix :: [Positive Integer] , loop :: NonEmpty (Positive Integer) , threadName :: String }- deriving Show+ deriving (Show) -- FIXME Why is this not in QuickCheck?-instance Arbitrary a => Arbitrary (NonEmpty a) where+instance (Arbitrary a) => Arbitrary (NonEmpty a) where arbitrary = (NonEmpty.:|) <$> arbitrary <*> arbitrary - genScript :: ThreadName -> Gen Script genScript threadName = do prefix <- arbitrary loop <- arbitrary- return Script { .. }+ return Script {..} instance Arbitrary Scripts where arbitrary = do nScripts <- getPositive <$> (arbitrary :: Gen (Positive Integer))- getScripts <- mapM genScript $ show <$> NonEmpty.fromList [1..nScripts]- return Scripts { .. }+ getScripts <- mapM genScript $ show <$> NonEmpty.fromList [1 .. nScripts]+ return Scripts {..} -newtype Scripts = Scripts { getScripts :: NonEmpty Script }- deriving Show+newtype Scripts = Scripts {getScripts :: NonEmpty Script}+ deriving (Show) type ThreadName = String interpretScript :: Script -> MySchedule ()-interpretScript Script { .. } = do+interpretScript Script {..} = do let perform interval = myLog threadName >> wait (getPositive interval) mapM_ perform prefix forever $ mapM_ perform loop@@ -147,7 +177,7 @@ interpretScripts = NonEmpty.map interpretScript . getScripts sizeScript :: Script -> Int-sizeScript Script { .. } = fromInteger $ sum (getPositive <$> prefix) + sum (getPositive <$> loop)+sizeScript Script {..} = fromInteger $ sum (getPositive <$> prefix) + sum (getPositive <$> loop) sizeScripts :: Scripts -> Int sizeScripts = sum . fmap sizeScript . getScripts
test/Yield.hs view
@@ -6,76 +6,83 @@ -- base import Control.Monad (forever)+import Data.Foldable (forM_) import Data.List.NonEmpty (NonEmpty, reverse)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (fromJust, isJust, maybeToList) -- transformers import Control.Monad.Trans.Class-import Control.Monad.Trans.Writer (Writer, tell, runWriter, execWriter)+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer (Writer, execWriter, runWriter, tell) +-- QuickCheck+import Test.QuickCheck (NonEmptyList (NonEmpty), counterexample, (===), (==>))+ -- test-framework import Test.Framework -- test-framework-hunit import Test.Framework.Providers.HUnit +-- test-framework-quickcheck2+import Test.Framework.Providers.QuickCheck2 (testProperty)+ -- HUnit import Test.HUnit hiding (Test) -- monad-schedule-import Control.Monad.Schedule.Class (scheduleAndFinish, schedule)+import Control.Monad.Schedule.Class (schedule, scheduleAndFinish)+import Control.Monad.Schedule.Trans (runScheduleIO, runScheduleT) import Control.Monad.Schedule.Yield-import Control.Monad.Schedule.Trans (runScheduleT, runScheduleIO)-import Control.Monad.Trans.Reader-import Data.Foldable (forM_)-import Test.QuickCheck (NonEmptyList(NonEmpty), (===), (==>), counterexample)-import qualified Data.List.NonEmpty as NonEmpty-import Data.Maybe (fromJust, isJust, maybeToList)-import Test.Framework.Providers.QuickCheck2 (testProperty) sampleActions :: NonEmpty (MySchedule ()) sampleActions = [yield, yield] -tests = testGroup "Trans"- [ testCase "Only leftover time is waited"- $ assertRunsLike sampleActions [Yielded]- , testCase "Scheduling two waits"- $ assertRunsEqual sampleActions (Data.List.NonEmpty.reverse sampleActions)- , testCase "Different number of waits"- $ assertRunsLike- [ myLog "Thread 1 starts" >> yield >> myLog "Thread 1 action" >> yield >> myLog "Thread 1 done"- , myLog "Thread 2 starts" >> yield >> myLog "Thread 2 done"- ]- [ Log "Thread 1 starts"- , Log "Thread 2 starts"- , Yielded- , Log "Thread 1 action"- , Log "Thread 2 done"- , Yielded- , Log "Thread 1 done"- ]- , testCase "Blocking thread doesn't starve other thread"- $ assertRunContains- [ forever $ myLog "Busy loop starts" >> yield >> myLog "Busy loop ends"- , myLog "One off thread starts" >> yield >> myLog "One off thread does a thing" >> yield >> myLog "One off thread done"- ]- $ Log "One off thread done"- , testCase "Programs with continuations can be scheduled"- $ assertProgramsInitiallyRunsLike- [[Log "Thread 1 active",Log "Thread 2 active",Yielded],[Log "Thread 1 active",Log "Thread 2 active",Yielded],[Log "Thread 1 active",Log "Thread 2 active",Yielded],[Log "Thread 1 active",Log "Thread 2 active",Yielded],[Log "Thread 1 active",Log "Thread 2 active",Yielded]]- [foreverP (const ["Thread 1 active"]), foreverP (const ["Thread 2 active"])]- $ repeat True- , testCase "Two programs that tick alternately can be scheduled"- $ assertProgramsInitiallyRunsLike- [[Log "1 Nope",Log "2 Yes",Yielded,Log "1 Nope"],[Log "2 Nope",Yielded,Log "2 Nope",Log "1 Yes",Yielded,Log "2 Nope"],[Log "1 Yes",Yielded,Log "2 Nope"],[Log "1 Nope",Yielded,Log "1 Nope",Log "2 Yes",Yielded,Log "1 Nope"],[Log "2 Yes",Yielded,Log "1 Nope"],[Log "2 Yes",Yielded,Log "1 Nope"],[Log "2 Yes",Yielded,Log "1 Nope"],[Log "2 Nope",Yielded,Log "2 Nope",Log "1 Yes",Yielded,Log "2 Nope"]]- twoPrograms- [True, False, False, True, True, True, True, False, False]- , testProperty "Two programs that tick alternately can be scheduled with arbitrary input"- $ \(inputs :: [Bool]) skip ->- let log = take (20 * length inputs) $ drop skip $ concat $ runProgramWith inputs $ schedulePrograms twoPrograms- isContained expectedEntry = expectedEntry `elem` log- in counterexample (show log)- $ all (`elem` drop skip inputs) ([True, False] :: [Bool]) ==> all isContained ([Log "1 Yes", Log "2 Yes"] :: [Event])- ]+tests =+ testGroup+ "Trans"+ [ testCase "Only leftover time is waited" $+ assertRunsLike sampleActions [Yielded]+ , testCase "Scheduling two waits" $+ assertRunsEqual sampleActions (Data.List.NonEmpty.reverse sampleActions)+ , testCase "Different number of waits" $+ assertRunsLike+ [ myLog "Thread 1 starts" >> yield >> myLog "Thread 1 action" >> yield >> myLog "Thread 1 done"+ , myLog "Thread 2 starts" >> yield >> myLog "Thread 2 done"+ ]+ [ Log "Thread 1 starts"+ , Log "Thread 2 starts"+ , Yielded+ , Log "Thread 1 action"+ , Log "Thread 2 done"+ , Yielded+ , Log "Thread 1 done"+ ]+ , testCase "Blocking thread doesn't starve other thread"+ $ assertRunContains+ [ forever $ myLog "Busy loop starts" >> yield >> myLog "Busy loop ends"+ , myLog "One off thread starts" >> yield >> myLog "One off thread does a thing" >> yield >> myLog "One off thread done"+ ]+ $ Log "One off thread done"+ , testCase "Programs with continuations can be scheduled"+ $ assertProgramsInitiallyRunsLike+ [[Log "Thread 1 active", Log "Thread 2 active", Yielded], [Log "Thread 1 active", Log "Thread 2 active", Yielded], [Log "Thread 1 active", Log "Thread 2 active", Yielded], [Log "Thread 1 active", Log "Thread 2 active", Yielded], [Log "Thread 1 active", Log "Thread 2 active", Yielded]]+ [foreverP (const ["Thread 1 active"]), foreverP (const ["Thread 2 active"])]+ $ repeat True+ , testCase "Two programs that tick alternately can be scheduled" $+ assertProgramsInitiallyRunsLike+ [[Log "1 Nope", Log "2 Yes", Yielded, Log "1 Nope"], [Log "2 Nope", Yielded, Log "2 Nope", Log "1 Yes", Yielded, Log "2 Nope"], [Log "1 Yes", Yielded, Log "2 Nope"], [Log "1 Nope", Yielded, Log "1 Nope", Log "2 Yes", Yielded, Log "1 Nope"], [Log "2 Yes", Yielded, Log "1 Nope"], [Log "2 Yes", Yielded, Log "1 Nope"], [Log "2 Yes", Yielded, Log "1 Nope"], [Log "2 Nope", Yielded, Log "2 Nope", Log "1 Yes", Yielded, Log "2 Nope"]]+ twoPrograms+ [True, False, False, True, True, True, True, False, False]+ , testProperty "Two programs that tick alternately can be scheduled with arbitrary input" $+ \(inputs :: [Bool]) skip ->+ let log = take (20 * length inputs) $ drop skip $ concat $ runProgramWith inputs $ schedulePrograms twoPrograms+ isContained expectedEntry = expectedEntry `elem` log+ in counterexample (show log) $+ all (`elem` drop skip inputs) ([True, False] :: [Bool]) ==>+ all isContained ([Log "1 Yes", Log "2 Yes"] :: [Event])+ ] assertRunsEqual :: NonEmpty (MySchedule a1) -> NonEmpty (MySchedule a2) -> Assertion assertRunsEqual actions1 actions2 = assertEqual "Should run the same under scheduling" (runMySchedule actions1) (runMySchedule actions2)@@ -89,7 +96,6 @@ assertInitiallyRunsLike :: NonEmpty (MySchedule a) -> [Event] -> Assertion assertInitiallyRunsLike actions events = assertEqual "Should, at the beginning, run like the following under scheduling" events $ take (length events) $ runMySchedule actions - data Event = Log String | Yielded@@ -106,7 +112,7 @@ type MyReaderSchedule a = YieldT (ReaderT Bool (Writer [Event])) a -- Ok this is basically ListT-newtype Program = Program { unProgram :: MyReaderSchedule (Maybe Program) }+newtype Program = Program {unProgram :: MyReaderSchedule (Maybe Program)} foreverP :: (Bool -> [String]) -> Program foreverP action = go@@ -140,7 +146,7 @@ ] runProgram :: Program -> MyReaderSchedule ()-runProgram Program { .. } = do+runProgram Program {..} = do tick <- unProgram forM_ tick runProgram @@ -155,10 +161,13 @@ -- Should be possible with some recursion scheme runProgramWith :: [Bool] -> Program -> [[Event]] runProgramWith [] _ = []-runProgramWith (input : inputs) Program { .. }- = let (cont, events) = runWriter $ flip runReaderT input $ runScheduleT (const $ lift $ tell [Yielded]) unProgram- in events : (runProgramWith inputs =<< maybeToList cont)+runProgramWith (input : inputs) Program {..} =+ let (cont, events) = runWriter $ flip runReaderT input $ runScheduleT (const $ lift $ tell [Yielded]) unProgram+ in events : (runProgramWith inputs =<< maybeToList cont) assertProgramsInitiallyRunsLike :: [[Event]] -> NonEmpty Program -> [Bool] -> Assertion-assertProgramsInitiallyRunsLike events programs inputs = assertEqual "The programs, when scheduled, should run like" events- $ take (length events) $ runProgramWith inputs $ schedulePrograms programs+assertProgramsInitiallyRunsLike events programs inputs =+ assertEqual "The programs, when scheduled, should run like" events $+ take (length events) $+ runProgramWith inputs $+ schedulePrograms programs