{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}

{- |
This module supplies a general purpose monad transformer
that adds a syntactical "delay", or "waiting" side effect.
-}
module Control.Monad.Schedule.Trans where

-- base
import Control.Arrow (Arrow (second))
import Control.Category ((>>>))
import Control.Concurrent
import qualified Control.Concurrent as C
import Control.Monad (join)
import Data.Functor.Classes
import Data.Functor.Identity
import Data.List (partition)
import Data.List.NonEmpty as N hiding (partition)
import Data.Ord (comparing)

-- 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
  { forall diff a. Wait diff a -> diff
getDiff :: diff
  -- ^ The duration to wait.
  , forall diff a. Wait diff a -> a
awaited :: a
  -- ^ The encapsulated value.
  }
  deriving ((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
$cfmap :: forall diff a b. (a -> b) -> Wait diff a -> Wait diff b
fmap :: forall a b. (a -> b) -> Wait diff a -> Wait diff b
$c<$ :: forall diff a b. a -> Wait diff b -> Wait diff a
<$ :: forall a b. a -> Wait diff b -> Wait diff a
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
$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
/= :: 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
$cshowsPrec :: forall diff a. (Show diff, Show a) => Int -> Wait diff a -> ShowS
showsPrec :: Int -> Wait diff a -> ShowS
$cshow :: forall diff a. (Show diff, Show a) => Wait diff a -> String
show :: Wait diff a -> String
$cshowList :: forall diff a. (Show diff, Show a) => [Wait diff a] -> ShowS
showList :: [Wait diff a] -> ShowS
Show)

instance (Eq diff) => Eq1 (Wait diff) where
  liftEq :: forall a b. (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 :: forall diff a. Ord diff => 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 :: forall (m :: * -> *) diff. Monad m => diff -> ScheduleT diff m ()
wait diff
diff = m (FreeF (Wait diff) () (FreeT (Wait diff) m ()))
-> FreeT (Wait diff) m ()
forall (f :: * -> *) (m :: * -> *) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF (Wait diff) () (FreeT (Wait diff) m ()))
 -> FreeT (Wait diff) m ())
-> m (FreeF (Wait diff) () (FreeT (Wait diff) m ()))
-> FreeT (Wait diff) m ()
forall a b. (a -> b) -> a -> b
$ FreeF (Wait diff) () (FreeT (Wait diff) m ())
-> m (FreeF (Wait diff) () (FreeT (Wait diff) m ()))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (FreeF (Wait diff) () (FreeT (Wait diff) m ())
 -> m (FreeF (Wait diff) () (FreeT (Wait diff) m ())))
-> FreeF (Wait diff) () (FreeT (Wait diff) m ())
-> m (FreeF (Wait diff) () (FreeT (Wait diff) m ()))
forall a b. (a -> b) -> a -> b
$ Wait diff (FreeT (Wait diff) m ())
-> FreeF (Wait diff) () (FreeT (Wait diff) m ())
forall (f :: * -> *) a b. f b -> FreeF f a b
Free (Wait diff (FreeT (Wait diff) m ())
 -> FreeF (Wait diff) () (FreeT (Wait diff) m ()))
-> Wait diff (FreeT (Wait diff) m ())
-> FreeF (Wait diff) () (FreeT (Wait diff) m ())
forall a b. (a -> b) -> a -> b
$ diff
-> FreeT (Wait diff) m () -> Wait diff (FreeT (Wait diff) m ())
forall diff a. diff -> a -> Wait diff a
Wait diff
diff (FreeT (Wait diff) m () -> Wait diff (FreeT (Wait diff) m ()))
-> FreeT (Wait diff) m () -> Wait diff (FreeT (Wait diff) m ())
forall a b. (a -> b) -> a -> b
$ () -> FreeT (Wait diff) m ()
forall a. a -> FreeT (Wait diff) m a
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 :: forall (m :: * -> *) diff a.
Monad m =>
(diff -> m ()) -> ScheduleT diff m a -> m a
runScheduleT diff -> m ()
waitAction = (Wait diff (m a) -> m a) -> FreeT (Wait 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) -> FreeT (Wait diff) m a -> m a)
-> (Wait diff (m a) -> m a) -> FreeT (Wait 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 a b. m a -> m b -> m b
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 :: forall (m :: * -> *) n a.
(MonadIO m, Integral n) =>
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 a. IO a -> m a
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 :: forall (m :: * -> *) diff a.
Monad m =>
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 a. a -> m a
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 a. a -> m a
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 :: forall a.
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 a. 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 :: forall diff. (Eq diff, TimeDifference diff) => 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 :: forall a.
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 (m :: * -> *) a. Monad m => m a -> FreeT (Wait 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 a. NonEmpty (m a) -> m (NonEmpty a, [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 :: forall diff a b.
Ord diff =>
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 :: forall (f :: * -> *) a b. [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 :: forall diff a.
TimeDifference diff =>
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 :: 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 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 :: 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 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 a. a -> FreeT (Wait 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 a. a -> 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 a.
NonEmpty (FreeT (Wait diff) m a)
-> FreeT (Wait diff) m (NonEmpty a, [FreeT (Wait 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 a. a -> 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))