{- |
This module supplies a general purpose monad transformer
that adds a syntactical "delay", or "waiting" side effect.

This allows for universal and deterministic scheduling of clocks
that implement their waiting actions in 'ScheduleT'.
See 'FRP.Rhine.Schedule.Trans' for more details.
-}

{-# LANGUAGE DeriveFunctor #-}
module Control.Monad.Schedule where


-- base
import Control.Concurrent

-- transformers
import Control.Monad.IO.Class

-- free
import Control.Monad.Trans.Free


-- TODO Implement Time via StateT

{- |
A functor implementing a syntactical "waiting" action.

* 'diff' represents the duration to wait.
* 'a' is the encapsulated value.
-}
data Wait diff a = Wait diff a
  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 :: Type -> Type).
(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

{- |
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)


-- | 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 :: Type -> Type) (m :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) (m :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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 :: Type -> Type) 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

-- TODO The definition and type signature are both a mouthful. Is there a simpler concept?
-- | Runs two values in 'ScheduleT' concurrently
--   and returns the first one that yields a value
--   (defaulting to the first argument),
--   and a continuation for the other value.
race
  :: (Ord diff, Num diff, Monad m)
  => ScheduleT    diff m a -> ScheduleT diff m b
  -> ScheduleT    diff m (Either
       (                 a,   ScheduleT diff m b)
       (ScheduleT diff m a,                    b)
     )
race :: ScheduleT diff m a
-> ScheduleT diff m b
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
race (FreeT m (FreeF (Wait diff) a (ScheduleT diff m a))
ma) (FreeT m (FreeF (Wait diff) b (ScheduleT diff m b))
mb) = m (FreeF
     (Wait diff)
     (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
     (ScheduleT
        diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
forall (f :: Type -> Type) (m :: Type -> Type) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF
      (Wait diff)
      (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
      (ScheduleT
         diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
 -> ScheduleT
      diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
-> m (FreeF
        (Wait diff)
        (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
        (ScheduleT
           diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
forall a b. (a -> b) -> a -> b
$ do
  -- Perform the side effects to find out how long each 'ScheduleT' values need to wait.
  FreeF (Wait diff) a (ScheduleT diff m a)
aWait <- m (FreeF (Wait diff) a (ScheduleT diff m a))
ma
  FreeF (Wait diff) b (ScheduleT diff m b)
bWait <- m (FreeF (Wait diff) b (ScheduleT diff m b))
mb
  case FreeF (Wait diff) a (ScheduleT diff m a)
aWait of
    -- 'a' doesn't need to wait. Return immediately and leave the continuation for 'b'.
    Pure a
a -> FreeF
  (Wait diff)
  (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
  (ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
-> m (FreeF
        (Wait diff)
        (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
        (ScheduleT
           diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FreeF
   (Wait diff)
   (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
   (ScheduleT
      diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
 -> m (FreeF
         (Wait diff)
         (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
         (ScheduleT
            diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))))
-> FreeF
     (Wait diff)
     (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
     (ScheduleT
        diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
-> m (FreeF
        (Wait diff)
        (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
        (ScheduleT
           diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
forall a b. (a -> b) -> a -> b
$ Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
-> FreeF
     (Wait diff)
     (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
     (ScheduleT
        diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
forall (f :: Type -> Type) a b. a -> FreeF f a b
Pure (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
 -> FreeF
      (Wait diff)
      (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
      (ScheduleT
         diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
-> Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
-> FreeF
     (Wait diff)
     (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
     (ScheduleT
        diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
forall a b. (a -> b) -> a -> b
$ (a, ScheduleT diff m b)
-> Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
forall a b. a -> Either a b
Left (a
a, m (FreeF (Wait diff) b (ScheduleT diff m b)) -> ScheduleT diff m b
forall (f :: Type -> Type) (m :: Type -> Type) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT (m (FreeF (Wait diff) b (ScheduleT diff m b))
 -> ScheduleT diff m b)
-> m (FreeF (Wait diff) b (ScheduleT diff m b))
-> ScheduleT diff m b
forall a b. (a -> b) -> a -> b
$ FreeF (Wait diff) b (ScheduleT diff m b)
-> m (FreeF (Wait diff) b (ScheduleT diff m b))
forall (m :: Type -> Type) a. Monad m => a -> m a
return FreeF (Wait diff) b (ScheduleT diff m b)
bWait)
    -- 'a' needs to wait, so we need to inspect 'b' as well and see which one needs to wait longer.
    Free (Wait diff
aDiff ScheduleT diff m a
aCont) -> case FreeF (Wait diff) b (ScheduleT diff m b)
bWait of
    -- 'b' doesn't need to wait. Return immediately and leave the continuation for 'a'.
      Pure b
b -> FreeF
  (Wait diff)
  (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
  (ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
-> m (FreeF
        (Wait diff)
        (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
        (ScheduleT
           diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
forall (m :: Type -> Type) a. Monad m => a -> m a
return (FreeF
   (Wait diff)
   (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
   (ScheduleT
      diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
 -> m (FreeF
         (Wait diff)
         (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
         (ScheduleT
            diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))))
-> FreeF
     (Wait diff)
     (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
     (ScheduleT
        diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
-> m (FreeF
        (Wait diff)
        (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
        (ScheduleT
           diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
forall a b. (a -> b) -> a -> b
$ Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
-> FreeF
     (Wait diff)
     (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
     (ScheduleT
        diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
forall (f :: Type -> Type) a b. a -> FreeF f a b
Pure (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
 -> FreeF
      (Wait diff)
      (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
      (ScheduleT
         diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
-> Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
-> FreeF
     (Wait diff)
     (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
     (ScheduleT
        diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
forall a b. (a -> b) -> a -> b
$ (ScheduleT diff m a, b)
-> Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
forall a b. b -> Either a b
Right (diff -> ScheduleT diff m ()
forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait diff
aDiff ScheduleT diff m () -> ScheduleT diff m a -> ScheduleT diff m a
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> ScheduleT diff m a
aCont, b
b)
      -- Both need to wait. Which one needs to wait longer?
      Free (Wait diff
bDiff ScheduleT diff m b
bCont) -> if diff
aDiff diff -> diff -> Bool
forall a. Ord a => a -> a -> Bool
<= diff
bDiff
        -- 'a' yields first, or both are done simultaneously.
        then ScheduleT
  diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
-> m (FreeF
        (Wait diff)
        (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
        (ScheduleT
           diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
forall (f :: Type -> Type) (m :: Type -> Type) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT (ScheduleT
   diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
 -> m (FreeF
         (Wait diff)
         (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
         (ScheduleT
            diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))))
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
-> m (FreeF
        (Wait diff)
        (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
        (ScheduleT
           diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
forall a b. (a -> b) -> a -> b
$ do
          -- Perform the wait action that we've deconstructed
          diff -> ScheduleT diff m ()
forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait diff
aDiff
          -- Recurse, since more wait actions might be hidden in 'a' and 'b'. 'b' doesn't need to wait as long, since we've already waited for 'aDiff'.
          ScheduleT diff m a
-> ScheduleT diff m b
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
forall diff (m :: Type -> Type) a b.
(Ord diff, Num diff, Monad m) =>
ScheduleT diff m a
-> ScheduleT diff m b
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
race ScheduleT diff m a
aCont (ScheduleT diff m b
 -> ScheduleT
      diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))
-> ScheduleT diff m b
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
forall a b. (a -> b) -> a -> b
$ diff -> ScheduleT diff m ()
forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait (diff
bDiff diff -> diff -> diff
forall a. Num a => a -> a -> a
- diff
aDiff) ScheduleT diff m () -> ScheduleT diff m b -> ScheduleT diff m b
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> ScheduleT diff m b
bCont
        -- 'b' yields first. Analogously.
        else ScheduleT
  diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
-> m (FreeF
        (Wait diff)
        (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
        (ScheduleT
           diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
forall (f :: Type -> Type) (m :: Type -> Type) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT (ScheduleT
   diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
 -> m (FreeF
         (Wait diff)
         (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
         (ScheduleT
            diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)))))
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
-> m (FreeF
        (Wait diff)
        (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
        (ScheduleT
           diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))))
forall a b. (a -> b) -> a -> b
$ do
          diff -> ScheduleT diff m ()
forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait diff
bDiff
          ScheduleT diff m a
-> ScheduleT diff m b
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
forall diff (m :: Type -> Type) a b.
(Ord diff, Num diff, Monad m) =>
ScheduleT diff m a
-> ScheduleT diff m b
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
race (diff -> ScheduleT diff m ()
forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait (diff
aDiff diff -> diff -> diff
forall a. Num a => a -> a -> a
- diff
bDiff) ScheduleT diff m () -> ScheduleT diff m a -> ScheduleT diff m a
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> ScheduleT diff m a
aCont) ScheduleT diff m b
bCont

-- | Runs both schedules concurrently and returns their results at the end.
async
  :: (Ord diff, Num diff, Monad m)
  => ScheduleT diff m  a -> ScheduleT diff m b
  -> ScheduleT diff m (a,                    b)
async :: ScheduleT diff m a -> ScheduleT diff m b -> ScheduleT diff m (a, b)
async ScheduleT diff m a
aSched ScheduleT diff m b
bSched = do
  Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
ab <- ScheduleT diff m a
-> ScheduleT diff m b
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
forall diff (m :: Type -> Type) a b.
(Ord diff, Num diff, Monad m) =>
ScheduleT diff m a
-> ScheduleT diff m b
-> ScheduleT
     diff m (Either (a, ScheduleT diff m b) (ScheduleT diff m a, b))
race ScheduleT diff m a
aSched ScheduleT diff m b
bSched
  case Either (a, ScheduleT diff m b) (ScheduleT diff m a, b)
ab of
    Left  (a
a, ScheduleT diff m b
bCont) -> do
      b
b <- ScheduleT diff m b
bCont
      (a, b) -> ScheduleT diff m (a, b)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
a, b
b)
    Right (ScheduleT diff m a
aCont, b
b) -> do
      a
a <- ScheduleT diff m a
aCont
      (a, b) -> ScheduleT diff m (a, b)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
a, b
b)