{-# LANGUAGE DeriveFunctor #-}

{- |
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.
-}
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 (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
<$ :: forall a b. a -> Wait diff b -> Wait diff a
$c<$ :: forall diff a b. a -> Wait diff b -> Wait diff a
fmap :: forall a b. (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 :: forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait diff
diff = forall (f :: Type -> Type) (m :: Type -> Type) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. f b -> FreeF f a b
Free forall a b. (a -> b) -> a -> b
$ forall diff a. diff -> a -> Wait diff a
Wait diff
diff forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: Type -> Type) diff a.
Monad m =>
(diff -> m ()) -> ScheduleT diff m a -> m a
runScheduleT diff -> m ()
waitAction = forall (f :: Type -> Type) (m :: Type -> Type) a.
(Functor f, Monad m) =>
(f (m a) -> m a) -> FreeT f m a -> m a
iterT forall a b. (a -> b) -> a -> b
$ \(Wait diff
n m a
ma) -> diff -> m ()
waitAction diff
n 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 :: forall (m :: Type -> Type) n a.
(MonadIO m, Integral n) =>
ScheduleT n m a -> m a
runScheduleIO = forall (m :: Type -> Type) diff a.
Monad m =>
(diff -> m ()) -> ScheduleT diff m a -> m a
runScheduleT forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IO ()
threadDelay forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* Int
1000) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: 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 (FreeT m (FreeF (Wait diff) a (FreeT (Wait diff) m a))
ma) (FreeT m (FreeF (Wait diff) b (FreeT (Wait diff) m b))
mb) = forall (f :: Type -> Type) (m :: Type -> Type) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT 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 (FreeT (Wait diff) m a)
aWait <- m (FreeF (Wait diff) a (FreeT (Wait diff) m a))
ma
  FreeF (Wait diff) b (FreeT (Wait diff) m b)
bWait <- m (FreeF (Wait diff) b (FreeT (Wait diff) m b))
mb
  case FreeF (Wait diff) a (FreeT (Wait diff) m a)
aWait of
    -- 'a' doesn't need to wait. Return immediately and leave the continuation for 'b'.
    Pure a
a -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. a -> FreeF f a b
Pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (a
a, forall (f :: Type -> Type) (m :: Type -> Type) a.
m (FreeF f a (FreeT f m a)) -> FreeT f m a
FreeT forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) a. Monad m => a -> m a
return FreeF (Wait diff) b (FreeT (Wait 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 FreeT (Wait diff) m a
aCont) -> case FreeF (Wait diff) b (FreeT (Wait diff) m b)
bWait of
      -- 'b' doesn't need to wait. Return immediately and leave the continuation for 'a'.
      Pure b
b -> forall (m :: Type -> Type) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: Type -> Type) a b. a -> FreeF f a b
Pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait diff
aDiff forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> FreeT (Wait diff) m a
aCont, b
b)
      -- Both need to wait. Which one needs to wait longer?
      Free (Wait diff
bDiff FreeT (Wait diff) m b
bCont) ->
        if diff
aDiff forall a. Ord a => a -> a -> Bool
<= diff
bDiff
          then -- 'a' yields first, or both are done simultaneously.
          forall (f :: Type -> Type) (m :: Type -> Type) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT forall a b. (a -> b) -> a -> b
$ do
            -- Perform the wait action that we've deconstructed
            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'.
            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 FreeT (Wait diff) m a
aCont forall a b. (a -> b) -> a -> b
$ forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait (diff
bDiff forall a. Num a => a -> a -> a
- diff
aDiff) forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> FreeT (Wait diff) m b
bCont
          else -- 'b' yields first. Analogously.
          forall (f :: Type -> Type) (m :: Type -> Type) a.
FreeT f m a -> m (FreeF f a (FreeT f m a))
runFreeT forall a b. (a -> b) -> a -> b
$ do
            forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait diff
bDiff
            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 (forall (m :: Type -> Type) diff.
Monad m =>
diff -> ScheduleT diff m ()
wait (diff
aDiff forall a. Num a => a -> a -> a
- diff
bDiff) forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> FreeT (Wait diff) m a
aCont) FreeT (Wait 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 :: forall diff (m :: Type -> Type) a b.
(Ord diff, Num diff, Monad m) =>
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 <- 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
      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
      forall (m :: Type -> Type) a. Monad m => a -> m a
return (a
a, b
b)