{- | 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.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) -- transformers import Control.Monad.IO.Class import Control.Monad.Trans.Class -- free import Control.Monad.Trans.Free -- time-domain import Data.TimeDomain -- monad-schedule import Control.Monad.Schedule.Class -- TODO Implement Time via StateT -- * Waiting action -- | A functor implementing a syntactical "waiting" action. data Wait diff a = Wait { Wait diff a -> diff getDiff :: diff -- ^ The duration to wait. , Wait diff a -> a awaited :: a -- ^ The encapsulated value. } deriving (a -> Wait diff b -> Wait diff a (a -> b) -> Wait diff a -> Wait diff b (forall a b. (a -> b) -> Wait diff a -> Wait diff b) -> (forall a b. a -> Wait diff b -> Wait diff a) -> Functor (Wait diff) forall a b. a -> Wait diff b -> Wait diff a forall a b. (a -> b) -> Wait diff a -> Wait diff b forall diff a b. a -> Wait diff b -> Wait diff a forall diff a b. (a -> b) -> Wait diff a -> Wait diff b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: a -> Wait diff b -> Wait diff a $c<$ :: forall diff a b. a -> Wait diff b -> Wait diff a fmap :: (a -> b) -> Wait diff a -> Wait diff b $cfmap :: forall diff a b. (a -> b) -> Wait diff a -> Wait diff b Functor, Wait diff a -> Wait diff a -> Bool (Wait diff a -> Wait diff a -> Bool) -> (Wait diff a -> Wait diff a -> Bool) -> Eq (Wait diff a) forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a forall diff a. (Eq diff, Eq a) => Wait diff a -> Wait diff a -> Bool /= :: Wait diff a -> Wait diff a -> Bool $c/= :: forall diff a. (Eq diff, Eq a) => Wait diff a -> Wait diff a -> Bool == :: Wait diff a -> Wait diff a -> Bool $c== :: forall diff a. (Eq diff, Eq a) => Wait diff a -> Wait diff a -> Bool Eq, Int -> Wait diff a -> ShowS [Wait diff a] -> ShowS Wait diff a -> String (Int -> Wait diff a -> ShowS) -> (Wait diff a -> String) -> ([Wait diff a] -> ShowS) -> Show (Wait diff a) forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a forall diff a. (Show diff, Show a) => Int -> Wait diff a -> ShowS forall diff a. (Show diff, Show a) => [Wait diff a] -> ShowS forall diff a. (Show diff, Show a) => Wait diff a -> String showList :: [Wait diff a] -> ShowS $cshowList :: forall diff a. (Show diff, Show a) => [Wait diff a] -> ShowS show :: Wait diff a -> String $cshow :: forall diff a. (Show diff, Show a) => Wait diff a -> String showsPrec :: Int -> Wait diff a -> ShowS $cshowsPrec :: forall diff a. (Show diff, Show a) => Int -> Wait diff a -> ShowS Show) instance Eq diff => Eq1 (Wait diff) where liftEq :: (a -> b -> Bool) -> Wait diff a -> Wait diff b -> Bool liftEq a -> b -> Bool eq (Wait diff diff1 a a) (Wait diff diff2 b b) = diff diff1 diff -> diff -> Bool forall a. Eq a => a -> a -> Bool == diff diff2 Bool -> Bool -> Bool && a -> b -> Bool eq a a b 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 :: Wait diff a -> Wait diff a -> Ordering compareWait = (Wait diff a -> diff) -> Wait diff a -> Wait diff a -> Ordering forall a b. Ord a => (b -> a) -> b -> b -> Ordering comparing Wait diff a -> diff forall diff a. Wait diff a -> diff getDiff -- * 'ScheduleT' {- | Values in @ScheduleT diff m@ are delayed computations with side effects in 'm'. Delays can occur between any two side effects, with lengths specified by a 'diff' value. These delays don't have any semantics, it can be given to them with 'runScheduleT'. -} type ScheduleT diff = FreeT (Wait diff) type Schedule diff = ScheduleT diff Identity -- | The side effect that waits for a specified amount. wait :: Monad m => diff -> ScheduleT diff m () wait :: diff -> ScheduleT diff m () wait diff diff = m (FreeF (Wait diff) () (ScheduleT diff m ())) -> ScheduleT diff m () forall (f :: * -> *) (m :: * -> *) a. m (FreeF f a (FreeT f m a)) -> FreeT f m a FreeT (m (FreeF (Wait diff) () (ScheduleT diff m ())) -> ScheduleT diff m ()) -> m (FreeF (Wait diff) () (ScheduleT diff m ())) -> ScheduleT diff m () forall a b. (a -> b) -> a -> b $ FreeF (Wait diff) () (ScheduleT diff m ()) -> m (FreeF (Wait diff) () (ScheduleT diff m ())) forall (m :: * -> *) a. Monad m => a -> m a return (FreeF (Wait diff) () (ScheduleT diff m ()) -> m (FreeF (Wait diff) () (ScheduleT diff m ()))) -> FreeF (Wait diff) () (ScheduleT diff m ()) -> m (FreeF (Wait diff) () (ScheduleT diff m ())) forall a b. (a -> b) -> a -> b $ Wait diff (ScheduleT diff m ()) -> FreeF (Wait diff) () (ScheduleT diff m ()) forall (f :: * -> *) a b. f b -> FreeF f a b Free (Wait diff (ScheduleT diff m ()) -> FreeF (Wait diff) () (ScheduleT diff m ())) -> Wait diff (ScheduleT diff m ()) -> FreeF (Wait diff) () (ScheduleT diff m ()) forall a b. (a -> b) -> a -> b $ diff -> ScheduleT diff m () -> Wait diff (ScheduleT diff m ()) forall diff a. diff -> a -> Wait diff a Wait diff diff (ScheduleT diff m () -> Wait diff (ScheduleT diff m ())) -> ScheduleT diff m () -> Wait diff (ScheduleT diff m ()) forall a b. (a -> b) -> a -> b $ () -> ScheduleT diff m () forall (m :: * -> *) a. Monad m => a -> m a 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 runScheduleT :: (diff -> m ()) -> ScheduleT diff m a -> m a runScheduleT diff -> m () waitAction = (Wait diff (m a) -> m a) -> ScheduleT diff m a -> m a forall (f :: * -> *) (m :: * -> *) a. (Functor f, Monad m) => (f (m a) -> m a) -> FreeT f m a -> m a iterT ((Wait diff (m a) -> m a) -> ScheduleT diff m a -> m a) -> (Wait diff (m a) -> m a) -> ScheduleT diff m a -> m a forall a b. (a -> b) -> a -> b $ \(Wait diff n m a ma) -> diff -> m () waitAction diff n m () -> m a -> m a forall (m :: * -> *) a b. Monad m => m a -> m b -> m b >> m a ma -- | Run a 'ScheduleT' value in a 'MonadIO', -- interpreting the times as milliseconds. runScheduleIO :: (MonadIO m, Integral n) => ScheduleT n m a -> m a runScheduleIO :: ScheduleT n m a -> m a runScheduleIO = (n -> m ()) -> ScheduleT n m a -> m a forall (m :: * -> *) diff a. Monad m => (diff -> m ()) -> ScheduleT diff m a -> m a runScheduleT ((n -> m ()) -> ScheduleT n m a -> m a) -> (n -> m ()) -> ScheduleT n m a -> m a forall a b. (a -> b) -> a -> b $ IO () -> m () forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO () -> m ()) -> (n -> IO ()) -> n -> m () forall b c a. (b -> c) -> (a -> b) -> a -> c . Int -> IO () threadDelay (Int -> IO ()) -> (n -> Int) -> n -> IO () forall b c a. (b -> c) -> (a -> b) -> a -> c . (Int -> Int -> Int forall a. Num a => a -> a -> a * Int 1000) (Int -> Int) -> (n -> Int) -> n -> Int forall b c a. (b -> c) -> (a -> b) -> a -> c . n -> Int forall a b. (Integral a, Num b) => a -> b 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]) execScheduleT :: ScheduleT diff m a -> m (a, [diff]) execScheduleT ScheduleT diff m a action = do FreeF (Wait diff) a (ScheduleT diff m a) free <- ScheduleT diff m a -> m (FreeF (Wait diff) a (ScheduleT diff m a)) forall (f :: * -> *) (m :: * -> *) a. FreeT f m a -> m (FreeF f a (FreeT f m a)) runFreeT ScheduleT diff m a action case FreeF (Wait diff) a (ScheduleT diff m a) free of Pure a a -> (a, [diff]) -> m (a, [diff]) forall (m :: * -> *) a. Monad m => a -> m a return (a a, []) Free (Wait diff diff ScheduleT diff m a cont) -> do (a a, [diff] diffs) <- ScheduleT diff m a -> m (a, [diff]) forall (m :: * -> *) diff a. Monad m => ScheduleT diff m a -> m (a, [diff]) execScheduleT ScheduleT diff m a cont (a, [diff]) -> m (a, [diff]) forall (m :: * -> *) a. Monad m => a -> m a return (a a, diff diff diff -> [diff] -> [diff] forall a. a -> [a] -> [a] : [diff] diffs) instance Ord diff => MonadSchedule (Wait diff) where schedule :: NonEmpty (Wait diff a) -> Wait diff (NonEmpty a, [Wait diff a]) schedule NonEmpty (Wait diff a) waits = let (Wait diff a smallestWait :| [Wait diff a] waits') = (Wait diff a -> Wait diff a -> Ordering) -> NonEmpty (Wait diff a) -> NonEmpty (Wait diff a) forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a N.sortBy Wait diff a -> Wait diff a -> Ordering forall diff a. Ord diff => Wait diff a -> Wait diff a -> Ordering compareWait NonEmpty (Wait diff a) waits in ((, [Wait diff a] waits') (NonEmpty a -> (NonEmpty a, [Wait diff a])) -> (a -> NonEmpty a) -> a -> (NonEmpty a, [Wait diff a]) forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> NonEmpty a forall (f :: * -> *) a. Applicative f => a -> f a pure) (a -> (NonEmpty a, [Wait diff a])) -> Wait diff a -> Wait diff (NonEmpty a, [Wait diff a]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Wait diff a smallestWait isZero :: (Eq diff, TimeDifference diff) => diff -> Bool isZero :: diff -> Bool isZero diff diff = diff diff diff -> diff -> diff forall d. TimeDifference d => d -> d -> d `difference` diff diff diff -> diff -> Bool forall a. Eq a => a -> a -> Bool == 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. instance (Ord diff, TimeDifference diff, Monad m, MonadSchedule m) => MonadSchedule (ScheduleT diff m) where schedule :: NonEmpty (ScheduleT diff m a) -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a]) schedule NonEmpty (ScheduleT diff m a) actions = do (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) frees, [m (FreeF (Wait diff) a (ScheduleT diff m a))] delayed) <- m (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)), [m (FreeF (Wait diff) a (ScheduleT diff m a))]) -> FreeT (Wait diff) m (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)), [m (FreeF (Wait diff) a (ScheduleT diff m a))]) forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (m (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)), [m (FreeF (Wait diff) a (ScheduleT diff m a))]) -> FreeT (Wait diff) m (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)), [m (FreeF (Wait diff) a (ScheduleT diff m a))])) -> m (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)), [m (FreeF (Wait diff) a (ScheduleT diff m a))]) -> FreeT (Wait diff) m (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)), [m (FreeF (Wait diff) a (ScheduleT diff m a))]) forall a b. (a -> b) -> a -> b $ NonEmpty (m (FreeF (Wait diff) a (ScheduleT diff m a))) -> m (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)), [m (FreeF (Wait diff) a (ScheduleT diff m a))]) forall (m :: * -> *) a. MonadSchedule m => NonEmpty (m a) -> m (NonEmpty a, [m a]) schedule (NonEmpty (m (FreeF (Wait diff) a (ScheduleT diff m a))) -> m (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)), [m (FreeF (Wait diff) a (ScheduleT diff m a))])) -> NonEmpty (m (FreeF (Wait diff) a (ScheduleT diff m a))) -> m (NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)), [m (FreeF (Wait diff) a (ScheduleT diff m a))]) forall a b. (a -> b) -> a -> b $ ScheduleT diff m a -> m (FreeF (Wait diff) a (ScheduleT diff m a)) forall (f :: * -> *) (m :: * -> *) a. FreeT f m a -> m (FreeF f a (FreeT f m a)) runFreeT (ScheduleT diff m a -> m (FreeF (Wait diff) a (ScheduleT diff m a))) -> NonEmpty (ScheduleT diff m a) -> NonEmpty (m (FreeF (Wait diff) a (ScheduleT diff m a))) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> NonEmpty (ScheduleT diff m a) actions NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) -> [ScheduleT diff m a] -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a]) forall diff (m :: * -> *) a. (TimeDifference diff, Ord diff, Monad m, MonadSchedule m) => NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) -> [ScheduleT diff m a] -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a]) shiftList ((FreeF (Wait diff) a (ScheduleT diff m a) -> FreeF (Wait diff) a (ScheduleT diff m a) -> Ordering) -> NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) -> NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a sortBy FreeF (Wait diff) a (ScheduleT diff m a) -> FreeF (Wait diff) a (ScheduleT diff m a) -> Ordering forall diff a b. Ord diff => FreeF (Wait diff) a b -> FreeF (Wait diff) a b -> Ordering compareFreeFWait NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) frees) ([ScheduleT diff m a] -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a])) -> [ScheduleT diff m a] -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a]) forall a b. (a -> b) -> a -> b $ m (FreeF (Wait diff) a (ScheduleT diff m a)) -> ScheduleT diff m a forall (f :: * -> *) (m :: * -> *) a. m (FreeF f a (FreeT f m a)) -> FreeT f m a FreeT (m (FreeF (Wait diff) a (ScheduleT diff m a)) -> ScheduleT diff m a) -> [m (FreeF (Wait diff) a (ScheduleT diff m a))] -> [ScheduleT diff m a] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [m (FreeF (Wait diff) a (ScheduleT diff m a))] 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 -> FreeF (Wait diff) a b -> Ordering compareFreeFWait :: FreeF (Wait diff) a b -> FreeF (Wait diff) a b -> Ordering compareFreeFWait (Pure a _) (Pure a _) = Ordering EQ compareFreeFWait (Pure a _) (Free Wait diff b _) = Ordering LT compareFreeFWait (Free Wait diff b _) (Pure a _) = Ordering GT compareFreeFWait (Free Wait diff b wait1) (Free Wait diff b wait2) = Wait diff b -> Wait diff b -> Ordering forall diff a. Ord diff => Wait diff a -> Wait diff a -> Ordering compareWait Wait diff b wait1 Wait diff b 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 a : [FreeF f a b] xs) = let ([a] as, [f b] fbs) = [FreeF f a b] -> ([a], [f b]) forall (f :: * -> *) a b. [FreeF f a b] -> ([a], [f b]) partitionFreeF [FreeF f a b] xs in (a a a -> [a] -> [a] forall a. a -> [a] -> [a] : [a] as, [f b] fbs) partitionFreeF (Free f b fb : [FreeF f a b] xs) = let ([a] as, [f b] fbs) = [FreeF f a b] -> ([a], [f b]) forall (f :: * -> *) a b. [FreeF f a b] -> ([a], [f b]) partitionFreeF [FreeF f a b] xs in ([a] as, f b fb f b -> [f b] -> [f b] forall a. a -> [a] -> [a] : [f b] fbs) -- Shift a waiting action by some duration shift :: TimeDifference diff => diff -> Wait diff a -> Wait diff a shift :: diff -> Wait diff a -> Wait diff a shift diff diff1 (Wait diff diff2 a a) = diff -> a -> Wait diff a forall diff a. diff -> a -> Wait diff a Wait (diff diff2 diff -> diff -> diff forall d. TimeDifference d => d -> d -> d `difference` diff diff1) a a -- Shift a list of free actions by the duration of the head -- (assuming the list is sorted). -- 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 :: NonEmpty (FreeF (Wait diff) a b) -> Either (NonEmpty a, [Wait diff b]) (Wait diff (b, [Wait diff b])) shiftListOnce NonEmpty (FreeF (Wait diff) a b) actions = case [FreeF (Wait diff) a b] -> ([a], [Wait diff b]) forall (f :: * -> *) a b. [FreeF f a b] -> ([a], [f b]) partitionFreeF ([FreeF (Wait diff) a b] -> ([a], [Wait diff b])) -> [FreeF (Wait diff) a b] -> ([a], [Wait diff b]) forall a b. (a -> b) -> a -> b $ NonEmpty (FreeF (Wait diff) a b) -> [FreeF (Wait diff) a b] forall a. NonEmpty a -> [a] toList NonEmpty (FreeF (Wait diff) a b) actions of (a a : [a] as, [Wait diff b] waits) -> (NonEmpty a, [Wait diff b]) -> Either (NonEmpty a, [Wait diff b]) (Wait diff (b, [Wait diff b])) forall a b. a -> Either a b Left (a a a -> [a] -> NonEmpty a forall a. a -> [a] -> NonEmpty a :| [a] as, [Wait diff b] waits) ([], Wait diff diff b cont : [Wait diff b] waits) -> Wait diff (b, [Wait diff b]) -> Either (NonEmpty a, [Wait diff b]) (Wait diff (b, [Wait diff b])) forall a b. b -> Either a b Right (Wait diff (b, [Wait diff b]) -> Either (NonEmpty a, [Wait diff b]) (Wait diff (b, [Wait diff b]))) -> Wait diff (b, [Wait diff b]) -> Either (NonEmpty a, [Wait diff b]) (Wait diff (b, [Wait diff b])) forall a b. (a -> b) -> a -> b $ diff -> (b, [Wait diff b]) -> Wait diff (b, [Wait diff b]) forall diff a. diff -> a -> Wait diff a Wait diff diff (b cont, diff -> Wait diff b -> Wait diff b forall diff a. TimeDifference diff => diff -> Wait diff a -> Wait diff a shift diff diff (Wait diff b -> Wait diff b) -> [Wait diff b] -> [Wait diff b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Wait diff b] waits) -- 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]) -- FIXME Don't I need to shift delayed as well? shiftList :: NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) -> [ScheduleT diff m a] -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a]) shiftList NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) actions [ScheduleT diff m a] delayed = case NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) -> Either (NonEmpty a, [Wait diff (ScheduleT diff m a)]) (Wait diff (ScheduleT diff m a, [Wait diff (ScheduleT diff m a)])) forall diff a b. TimeDifference diff => NonEmpty (FreeF (Wait diff) a b) -> Either (NonEmpty a, [Wait diff b]) (Wait diff (b, [Wait diff b])) shiftListOnce NonEmpty (FreeF (Wait diff) a (ScheduleT diff m a)) actions of -- Some actions returned. Wrap up the remaining ones. Left (NonEmpty a as, [Wait diff (ScheduleT diff m a)] waits) -> (NonEmpty a, [ScheduleT diff m a]) -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a]) forall (m :: * -> *) a. Monad m => a -> m a return (NonEmpty a as, [ScheduleT diff m a] delayed [ScheduleT diff m a] -> [ScheduleT diff m a] -> [ScheduleT diff m a] forall a. [a] -> [a] -> [a] ++ ((m (FreeF (Wait diff) a (ScheduleT diff m a)) -> ScheduleT diff m a forall (f :: * -> *) (m :: * -> *) a. m (FreeF f a (FreeT f m a)) -> FreeT f m a FreeT (m (FreeF (Wait diff) a (ScheduleT diff m a)) -> ScheduleT diff m a) -> (Wait diff (ScheduleT diff m a) -> m (FreeF (Wait diff) a (ScheduleT diff m a))) -> Wait diff (ScheduleT diff m a) -> ScheduleT diff m a forall b c a. (b -> c) -> (a -> b) -> a -> c . FreeF (Wait diff) a (ScheduleT diff m a) -> m (FreeF (Wait diff) a (ScheduleT diff m a)) forall (m :: * -> *) a. Monad m => a -> m a return (FreeF (Wait diff) a (ScheduleT diff m a) -> m (FreeF (Wait diff) a (ScheduleT diff m a))) -> (Wait diff (ScheduleT diff m a) -> FreeF (Wait diff) a (ScheduleT diff m a)) -> Wait diff (ScheduleT diff m a) -> m (FreeF (Wait diff) a (ScheduleT diff m a)) forall b c a. (b -> c) -> (a -> b) -> a -> c . Wait diff (ScheduleT diff m a) -> FreeF (Wait diff) a (ScheduleT diff m a) forall (f :: * -> *) a b. f b -> FreeF f a b Free) (Wait diff (ScheduleT diff m a) -> ScheduleT diff m a) -> [Wait diff (ScheduleT diff m a)] -> [ScheduleT diff m a] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Wait diff (ScheduleT diff m a)] waits)) -- No action has returned. -- Wait the remaining time and start scheduling again. Right (Wait diff diff (ScheduleT diff m a cont, [Wait diff (ScheduleT diff m a)] waits)) -> do diff -> ScheduleT diff m () forall (m :: * -> *) diff. Monad m => diff -> ScheduleT diff m () wait diff diff let ([Wait diff (ScheduleT diff m a)] zeroWaits, [Wait diff (ScheduleT diff m a)] nonZeroWaits) = (Wait diff (ScheduleT diff m a) -> Bool) -> [Wait diff (ScheduleT diff m a)] -> ([Wait diff (ScheduleT diff m a)], [Wait diff (ScheduleT diff m a)]) forall a. (a -> Bool) -> [a] -> ([a], [a]) partition (diff -> Bool forall diff. (Eq diff, TimeDifference diff) => diff -> Bool isZero (diff -> Bool) -> (Wait diff (ScheduleT diff m a) -> diff) -> Wait diff (ScheduleT diff m a) -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . Wait diff (ScheduleT diff m a) -> diff forall diff a. Wait diff a -> diff getDiff) [Wait diff (ScheduleT diff m a)] waits zeroWaitsUnwrapped :: [ScheduleT diff m a] zeroWaitsUnwrapped = Wait diff (ScheduleT diff m a) -> ScheduleT diff m a forall diff a. Wait diff a -> a awaited (Wait diff (ScheduleT diff m a) -> ScheduleT diff m a) -> [Wait diff (ScheduleT diff m a)] -> [ScheduleT diff m a] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Wait diff (ScheduleT diff m a)] zeroWaits NonEmpty (ScheduleT diff m a) -> ScheduleT diff m (NonEmpty a, [ScheduleT diff m a]) forall (m :: * -> *) a. MonadSchedule m => NonEmpty (m a) -> m (NonEmpty a, [m a]) schedule (ScheduleT diff m a cont ScheduleT diff m a -> [ScheduleT diff m a] -> NonEmpty (ScheduleT diff m a) forall a. a -> [a] -> NonEmpty a :| [ScheduleT diff m a] delayed [ScheduleT diff m a] -> [ScheduleT diff m a] -> [ScheduleT diff m a] forall a. [a] -> [a] -> [a] ++ [ScheduleT diff m a] zeroWaitsUnwrapped [ScheduleT diff m a] -> [ScheduleT diff m a] -> [ScheduleT diff m a] forall a. [a] -> [a] -> [a] ++ (m (FreeF (Wait diff) a (ScheduleT diff m a)) -> ScheduleT diff m a forall (f :: * -> *) (m :: * -> *) a. m (FreeF f a (FreeT f m a)) -> FreeT f m a FreeT (m (FreeF (Wait diff) a (ScheduleT diff m a)) -> ScheduleT diff m a) -> (Wait diff (ScheduleT diff m a) -> m (FreeF (Wait diff) a (ScheduleT diff m a))) -> Wait diff (ScheduleT diff m a) -> ScheduleT diff m a forall b c a. (b -> c) -> (a -> b) -> a -> c . FreeF (Wait diff) a (ScheduleT diff m a) -> m (FreeF (Wait diff) a (ScheduleT diff m a)) forall (m :: * -> *) a. Monad m => a -> m a return (FreeF (Wait diff) a (ScheduleT diff m a) -> m (FreeF (Wait diff) a (ScheduleT diff m a))) -> (Wait diff (ScheduleT diff m a) -> FreeF (Wait diff) a (ScheduleT diff m a)) -> Wait diff (ScheduleT diff m a) -> m (FreeF (Wait diff) a (ScheduleT diff m a)) forall b c a. (b -> c) -> (a -> b) -> a -> c . Wait diff (ScheduleT diff m a) -> FreeF (Wait diff) a (ScheduleT diff m a) forall (f :: * -> *) a b. f b -> FreeF f a b Free (Wait diff (ScheduleT diff m a) -> ScheduleT diff m a) -> [Wait diff (ScheduleT diff m a)] -> [ScheduleT diff m a] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> [Wait diff (ScheduleT diff m a)] nonZeroWaits))