monad-schedule 0.1.1.0 → 0.1.2.0

raw patch · 7 files changed

+425/−8 lines, 7 filesdep +HUnitdep +QuickCheckdep +monad-scheduledep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, QuickCheck, monad-schedule, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• monad-schedule.cabal +20/−1
• src/Control/Monad/Schedule/Class.hs +29/−5
• src/Control/Monad/Schedule/Trans.hs +13/−2
• test/Main.hs +37/−0
• test/Trans.hs +156/−0
• test/Yield.hs +164/−0

@@ -1,5 +1,11 @@ # Revision history for monad-schedule +## 0.1.2.0 -- 2022-06-26++* Added test suite+* Added further Writer instances+* Fixed bug in ScheduleT and YieldT+ ## 0.1.1.0 -- 2022-06-25  * Added Yield scheduling monad

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               monad-schedule-version:            0.1.1.0+version:            0.1.2.0 license:            MIT license-file:       LICENSE author:             Manuel Bärenz@@ -33,3 +33,22 @@     , time-domain >= 0.1   hs-source-dirs:   src   default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+    Trans+    Yield+  hs-source-dirs: test+  build-depends:+      base >= 4.11 && < 5+    , transformers >= 0.5+    , free >= 5.1+    , test-framework >= 0.8+    , test-framework-quickcheck2 >= 0.3+    , test-framework-hunit >= 0.3+    , HUnit >= 1.3+    , QuickCheck >= 2.12+    , monad-schedule+  default-language:    Haskell2010

@@ -40,7 +40,9 @@ import Control.Monad.Trans.Identity import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer+import qualified Control.Monad.Trans.Writer.CPS as CPSWriter+import qualified Control.Monad.Trans.Writer.Lazy as LazyWriter+import qualified Control.Monad.Trans.Writer.Strict as StrictWriter  {- | 'Monad's in which actions can be scheduled concurrently. @@ -135,11 +137,33 @@  -- | Write in the order of scheduling: --   The first actions to return write first.-instance (Monoid w, Functor m, MonadSchedule m) => MonadSchedule (WriterT w m) where-  schedule = fmap runWriterT+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 WriterT))-    >>> WriterT+    >>> 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.+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+    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.+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     where       assoc :: ((a, w), c) -> ((a, c), w)       assoc ((a, w), c) = ((a, c), w)

@@ -18,7 +18,8 @@ import Control.Monad (join) import Data.Functor.Classes import Data.Functor.Identity-import Data.List.NonEmpty as N+import Data.List.NonEmpty as N hiding (partition)+import Data.List (partition)  -- transformers import Control.Monad.IO.Class@@ -50,6 +51,8 @@   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 compareWait = comparing getDiff @@ -95,6 +98,9 @@ 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.@@ -103,6 +109,8 @@     (frees, delayed) <- lift $ schedule $ runFreeT <$> actions     shiftList (sortBy compareFreeFWait frees) $ FreeT <$> delayed     where+      -- We disregard the inner values @a@ and @b@,+      -- thus this is not an 'Ord' instance.       compareFreeFWait         :: Ord diff         => FreeF (Wait diff) a b@@ -154,6 +162,7 @@         -> [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))@@ -161,4 +170,6 @@         -- Wait the remaining time and start scheduling again.         Right (Wait diff (cont, waits)) -> do           wait diff-          schedule (cont :| delayed ++ ((FreeT . return . Free) <$> waits))+          let (zeroWaits, nonZeroWaits) = partition (isZero . getDiff) waits+              zeroWaitsUnwrapped = awaited <$> zeroWaits+          schedule (cont :| delayed ++ zeroWaitsUnwrapped ++ (FreeT . return . Free <$> nonZeroWaits))

@@ -0,0 +1,37 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE RecordWildCards #-}+-- base+import Control.Arrow+import Control.Monad+import Data.Functor.Identity+import Data.List.NonEmpty++-- test-framework+import Test.Framework++-- test-framework-hunit+import Test.Framework.Providers.HUnit++-- HUnit+import Test.HUnit hiding (Test)++-- test-framework-quickcheck2+import Test.Framework.Providers.QuickCheck2++-- QuickCheck+import Test.QuickCheck++-- monad-schedule (test)+import qualified Trans+import qualified Yield++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests =+  [ Trans.tests+  , Yield.tests+  ]

@@ -0,0 +1,156 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Trans where++-- base+-- base+import Control.Monad (forever, void)+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)++-- QuickCheck+import Test.QuickCheck+import qualified Test.QuickCheck as QuickCheck++-- test-framework+import Test.Framework++-- test-framework-hunit+import Test.Framework.Providers.HUnit++-- 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)++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+  ]++assertRunsEqual :: NonEmpty (MySchedule a1) -> NonEmpty (MySchedule a2) -> Assertion+assertRunsEqual actions1 actions2 = assertEqual "Should run the same under scheduling" (runMySchedule actions1) (runMySchedule actions2)++assertRunsLike :: NonEmpty (MySchedule a) -> [Event] -> Assertion+assertRunsLike actions events = assertEqual "Should run like the following under scheduling" events $ runMySchedule actions++assertRunContains :: NonEmpty (MySchedule a) -> Event -> Assertion+assertRunContains actions event = assertBool ("The run should contain the event " ++ show event) $ event `elem` runMySchedule actions++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+  | Waited Integer+  deriving (Eq, Show)++type MySchedule a = ScheduleT Integer (Writer [Event]) a++myLog :: String -> MySchedule ()+myLog = lift . tell . pure . Log++runMySchedule :: NonEmpty (MySchedule a) -> [Event]+runMySchedule = execWriter . runScheduleT (tell . pure . Waited) . scheduleAndFinish++data Script = Script+  { prefix :: [Positive Integer]+  , loop :: NonEmpty (Positive Integer)+  , threadName :: String+  }+  deriving Show++-- FIXME Why is this not in QuickCheck?+instance Arbitrary a => Arbitrary (NonEmpty a) where+  arbitrary = (NonEmpty.:|) <$> arbitrary <*> arbitrary+++genScript :: ThreadName -> Gen Script+genScript threadName = do+  prefix <- arbitrary+  loop <- arbitrary+  return Script { .. }++instance Arbitrary Scripts where+  arbitrary = do+    nScripts <- getPositive <$> (arbitrary :: Gen (Positive Integer))+    getScripts <- mapM genScript $ show <$> NonEmpty.fromList [1..nScripts]+    return Scripts { .. }++newtype Scripts = Scripts { getScripts :: NonEmpty Script }+  deriving Show++type ThreadName = String++interpretScript :: Script -> MySchedule ()+interpretScript Script { .. } = do+  let perform interval = myLog threadName >> wait (getPositive interval)+  mapM_ perform prefix+  forever $ mapM_ perform loop++interpretScripts :: Scripts -> NonEmpty (MySchedule ())+interpretScripts = NonEmpty.map interpretScript . getScripts++sizeScript :: Script -> Int+sizeScript Script { .. } = fromInteger $ sum (getPositive <$> prefix) + sum (getPositive <$> loop)++sizeScripts :: Scripts -> Int+sizeScripts = sum . fmap sizeScript . getScripts++threadNames :: Scripts -> NonEmpty ThreadName+threadNames = fmap threadName . getScripts

@@ -0,0 +1,164 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Yield where++-- base+import Control.Monad (forever)+import Data.List.NonEmpty (NonEmpty, reverse)++-- transformers+import Control.Monad.Trans.Class+import Control.Monad.Trans.Writer (Writer, tell, runWriter, execWriter)++-- test-framework+import Test.Framework++-- test-framework-hunit+import Test.Framework.Providers.HUnit++-- HUnit+import Test.HUnit hiding (Test)++-- monad-schedule+import Control.Monad.Schedule.Class (scheduleAndFinish, schedule)+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])+  ]++assertRunsEqual :: NonEmpty (MySchedule a1) -> NonEmpty (MySchedule a2) -> Assertion+assertRunsEqual actions1 actions2 = assertEqual "Should run the same under scheduling" (runMySchedule actions1) (runMySchedule actions2)++assertRunsLike :: NonEmpty (MySchedule a) -> [Event] -> Assertion+assertRunsLike actions events = assertEqual "Should run like the following under scheduling" events (runMySchedule actions)++assertRunContains :: NonEmpty (MySchedule a) -> Event -> Assertion+assertRunContains actions event = assertBool ("The run should contain the event " ++ show event) $ event `elem` runMySchedule actions++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+  deriving (Eq, Show)++type MySchedule a = YieldT (Writer [Event]) a++myLog :: String -> MySchedule ()+myLog = lift . tell . pure . Log++runMySchedule :: NonEmpty (MySchedule a) -> [Event]+runMySchedule = execWriter . runScheduleT (tell . pure . const Yielded) . scheduleAndFinish++type MyReaderSchedule a = YieldT (ReaderT Bool (Writer [Event])) a++-- Ok this is basically ListT+newtype Program = Program { unProgram :: MyReaderSchedule (Maybe Program) }++foreverP :: (Bool -> [String]) -> Program+foreverP action = go+  where+    go = Program $ do+      input <- lift ask+      lift $ lift $ tell $ Log <$> action input+      yield+      return $ Just go++-- Returning Left means looping further, Right means going to the next continuation+wait :: (Bool -> Either String String) -> Program+wait f = go+  where+    go = Program loop+    loop = do+      input <- lift ask+      case f input of+        Left msg -> do+          myReaderLog msg+          yield+          loop+        Right msg -> do+          myReaderLog msg+          yield+          return $ Just go++twoPrograms =+  [ wait (\b -> if b then Left "1 Nope" else Right "1 Yes")+  , wait (\b -> if b then Right "2 Yes" else Left "2 Nope")+  ]++runProgram :: Program -> MyReaderSchedule ()+runProgram Program { .. } = do+  tick <- unProgram+  forM_ tick runProgram++myReaderLog :: String -> MyReaderSchedule ()+myReaderLog = lift . lift . tell . pure . Log++schedulePrograms :: NonEmpty Program -> Program+schedulePrograms programs = Program $ do+  (done, running) <- schedule $ unProgram <$> programs+  return $ fmap schedulePrograms $ NonEmpty.nonEmpty $ (fromJust <$> NonEmpty.filter isJust done) ++ (Program <$> running)++-- 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)++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