-- |
-- Module     : Simulation.Aivika.Trans.Task
-- Copyright  : Copyright (c) 2009-2017, David Sorokin <david.sorokin@gmail.com>
-- License    : BSD3
-- Maintainer : David Sorokin <david.sorokin@gmail.com>
-- Stability  : experimental
-- Tested with: GHC 8.0.1
--
-- The 'Task' value represents a process that was already started in background.
-- We can check the completion of the task, receive notifications about changing
-- its state and even suspend an outer process awaiting the final result of the task.
-- It complements the 'Process' monad as it allows immediately continuing the main
-- computation without suspension.
--
module Simulation.Aivika.Trans.Task
       (-- * Task
        Task,
        TaskResult(..),
        taskId,
        tryGetTaskResult,
        taskResult,
        taskResultReceived,
        taskProcess,
        cancelTask,
        taskCancelled,
        -- * Running Task
        runTask,
        runTaskUsingId,
        -- * Spawning Tasks
        spawnTask,
        spawnTaskUsingId,
        spawnTaskWith,
        spawnTaskUsingIdWith,
        -- * Enqueueing Task
        enqueueTask,
        enqueueTaskUsingId,
        -- * Parallel Tasks
        taskParallelResult,
        taskParallelProcess) where

import Data.Monoid

import Control.Monad
import Control.Monad.Trans
import Control.Exception

import Simulation.Aivika.Trans.Ref.Base
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Internal.Specs
import Simulation.Aivika.Trans.Internal.Parameter
import Simulation.Aivika.Trans.Internal.Simulation
import Simulation.Aivika.Trans.Internal.Dynamics
import Simulation.Aivika.Trans.Internal.Event
import Simulation.Aivika.Trans.Internal.Cont
import Simulation.Aivika.Trans.Internal.Process
import Simulation.Aivika.Trans.Signal

-- | The task represents a process that was already started in background.
data Task m a =
  Task { forall (m :: * -> *) a. Task m a -> ProcessId m
taskId :: ProcessId m,
         -- ^ Return an identifier for the process that was launched
         -- in background for this task.
         forall (m :: * -> *) a. Task m a -> Ref m (Maybe (TaskResult a))
taskResultRef :: Ref m (Maybe (TaskResult a)),
         -- ^ It contains the result of the computation.
         forall (m :: * -> *) a. Task m a -> Signal m (TaskResult a)
taskResultReceived :: Signal m (TaskResult a)
         -- ^ Return a signal that notifies about receiving
         -- the result of the task.
       }

-- | Represents the result of the task.
data TaskResult a = TaskCompleted a
                    -- ^ the task was successfully completed and
                    -- it returned the specified result
                  | TaskError SomeException
                    -- ^ the specified exception was raised when performing the task.
                  | TaskCancelled
                    -- ^ the task was cancelled

-- | Try to get the task result immediately without suspension.
tryGetTaskResult :: MonadDES m => Task m a -> Event m (Maybe (TaskResult a))
{-# INLINABLE tryGetTaskResult #-}
tryGetTaskResult :: forall (m :: * -> *) a.
MonadDES m =>
Task m a -> Event m (Maybe (TaskResult a))
tryGetTaskResult Task m a
t = forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Task m a -> Ref m (Maybe (TaskResult a))
taskResultRef Task m a
t)

-- | Return the task result suspending the outer process if required.
taskResult :: MonadDES m => Task m a -> Process m (TaskResult a)
{-# INLINABLE taskResult #-}
taskResult :: forall (m :: * -> *) a.
MonadDES m =>
Task m a -> Process m (TaskResult a)
taskResult Task m a
t =
  do Maybe (TaskResult a)
x <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Task m a -> Ref m (Maybe (TaskResult a))
taskResultRef Task m a
t)
     case Maybe (TaskResult a)
x of
       Just TaskResult a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return TaskResult a
x
       Maybe (TaskResult a)
Nothing -> forall (m :: * -> *) a. MonadDES m => Signal m a -> Process m a
processAwait (forall (m :: * -> *) a. Task m a -> Signal m (TaskResult a)
taskResultReceived Task m a
t)

-- | Cancel the task.
cancelTask :: MonadDES m => Task m a -> Event m ()
{-# INLINABLE cancelTask #-}
cancelTask :: forall (m :: * -> *) a. MonadDES m => Task m a -> Event m ()
cancelTask Task m a
t =
  forall (m :: * -> *). MonadDES m => ProcessId m -> Event m ()
cancelProcessWithId (forall (m :: * -> *) a. Task m a -> ProcessId m
taskId Task m a
t)

-- | Test whether the task was cancelled.
taskCancelled :: MonadDES m => Task m a -> Event m Bool
{-# INLINABLE taskCancelled #-}
taskCancelled :: forall (m :: * -> *) a. MonadDES m => Task m a -> Event m Bool
taskCancelled Task m a
t =
  forall (m :: * -> *). MonadDES m => ProcessId m -> Event m Bool
processCancelled (forall (m :: * -> *) a. Task m a -> ProcessId m
taskId Task m a
t)

-- | Create a task by the specified process and its identifier.
newTaskUsingId :: MonadDES m => ProcessId m -> Process m a -> Event m (Task m a, Process m ())
{-# INLINABLE newTaskUsingId #-}
newTaskUsingId :: forall (m :: * -> *) a.
MonadDES m =>
ProcessId m -> Process m a -> Event m (Task m a, Process m ())
newTaskUsingId ProcessId m
pid Process m a
p =
  do Ref m (Maybe (TaskResult a))
r <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
SimulationLift t m =>
Simulation m a -> t m a
liftSimulation forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => a -> Simulation m (Ref m a)
newRef forall a. Maybe a
Nothing
     SignalSource m (TaskResult a)
s <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
SimulationLift t m =>
Simulation m a -> t m a
liftSimulation forall (m :: * -> *) a.
MonadDES m =>
Simulation m (SignalSource m a)
newSignalSource
     let t :: Task m a
t = Task { taskId :: ProcessId m
taskId = ProcessId m
pid,
                    taskResultRef :: Ref m (Maybe (TaskResult a))
taskResultRef = Ref m (Maybe (TaskResult a))
r,
                    taskResultReceived :: Signal m (TaskResult a)
taskResultReceived = forall (m :: * -> *) a. SignalSource m a -> Signal m a
publishSignal SignalSource m (TaskResult a)
s }
     let m :: Process m ()
m =
           do Ref m (TaskResult a)
v <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
SimulationLift t m =>
Simulation m a -> t m a
liftSimulation forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => a -> Simulation m (Ref m a)
newRef forall a. TaskResult a
TaskCancelled
              forall (m :: * -> *) a b.
MonadDES m =>
Process m a -> Process m b -> Process m a
finallyProcess
                (forall (m :: * -> *) e a.
(MonadDES m, Exception e) =>
Process m a -> (e -> Process m a) -> Process m a
catchProcess
                 (do a
a <- Process m a
p
                     forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> Event m ()
writeRef Ref m (TaskResult a)
v (forall a. a -> TaskResult a
TaskCompleted a
a))
                 (\SomeException
e ->
                   forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> Event m ()
writeRef Ref m (TaskResult a)
v (forall a. SomeException -> TaskResult a
TaskError SomeException
e)))
                (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
                 do TaskResult a
x <- forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef Ref m (TaskResult a)
v
                    forall (m :: * -> *) a. MonadRef m => Ref m a -> a -> Event m ()
writeRef Ref m (Maybe (TaskResult a))
r (forall a. a -> Maybe a
Just TaskResult a
x)
                    forall (m :: * -> *) a. SignalSource m a -> a -> Event m ()
triggerSignal SignalSource m (TaskResult a)
s TaskResult a
x)
     forall (m :: * -> *) a. Monad m => a -> m a
return (Task m a
t, Process m ()
m)

-- | Run the process with the specified identifier in background and
-- return the corresponding task immediately.
runTaskUsingId :: MonadDES m => ProcessId m -> Process m a -> Event m (Task m a)
{-# INLINABLE runTaskUsingId #-}
runTaskUsingId :: forall (m :: * -> *) a.
MonadDES m =>
ProcessId m -> Process m a -> Event m (Task m a)
runTaskUsingId ProcessId m
pid Process m a
p =
  do (Task m a
t, Process m ()
m) <- forall (m :: * -> *) a.
MonadDES m =>
ProcessId m -> Process m a -> Event m (Task m a, Process m ())
newTaskUsingId ProcessId m
pid Process m a
p
     forall (m :: * -> *).
MonadDES m =>
ProcessId m -> Process m () -> Event m ()
runProcessUsingId ProcessId m
pid Process m ()
m
     forall (m :: * -> *) a. Monad m => a -> m a
return Task m a
t

-- | Run the process in background and return the corresponding task immediately.
runTask :: MonadDES m => Process m a -> Event m (Task m a)
{-# INLINABLE runTask #-}
runTask :: forall (m :: * -> *) a.
MonadDES m =>
Process m a -> Event m (Task m a)
runTask Process m a
p =
  do ProcessId m
pid <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
SimulationLift t m =>
Simulation m a -> t m a
liftSimulation forall (m :: * -> *). MonadDES m => Simulation m (ProcessId m)
newProcessId
     forall (m :: * -> *) a.
MonadDES m =>
ProcessId m -> Process m a -> Event m (Task m a)
runTaskUsingId ProcessId m
pid Process m a
p

-- | Enqueue the process that will be started at the specified time with the given
-- identifier from the event queue. It returns the corresponding task immediately.
enqueueTaskUsingId :: MonadDES m => Double -> ProcessId m -> Process m a -> Event m (Task m a)
{-# INLINABLE enqueueTaskUsingId #-}
enqueueTaskUsingId :: forall (m :: * -> *) a.
MonadDES m =>
Double -> ProcessId m -> Process m a -> Event m (Task m a)
enqueueTaskUsingId Double
time ProcessId m
pid Process m a
p =
  do (Task m a
t, Process m ()
m) <- forall (m :: * -> *) a.
MonadDES m =>
ProcessId m -> Process m a -> Event m (Task m a, Process m ())
newTaskUsingId ProcessId m
pid Process m a
p
     forall (m :: * -> *).
MonadDES m =>
Double -> ProcessId m -> Process m () -> Event m ()
enqueueProcessUsingId Double
time ProcessId m
pid Process m ()
m
     forall (m :: * -> *) a. Monad m => a -> m a
return Task m a
t

-- | Enqueue the process that will be started at the specified time from the event queue.
-- It returns the corresponding task immediately.
enqueueTask :: MonadDES m => Double -> Process m a -> Event m (Task m a)
{-# INLINABLE enqueueTask #-}
enqueueTask :: forall (m :: * -> *) a.
MonadDES m =>
Double -> Process m a -> Event m (Task m a)
enqueueTask Double
time Process m a
p =
  do ProcessId m
pid <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
SimulationLift t m =>
Simulation m a -> t m a
liftSimulation forall (m :: * -> *). MonadDES m => Simulation m (ProcessId m)
newProcessId
     forall (m :: * -> *) a.
MonadDES m =>
Double -> ProcessId m -> Process m a -> Event m (Task m a)
enqueueTaskUsingId Double
time ProcessId m
pid Process m a
p

-- | Run using the specified identifier a child process in background and return
-- immediately the corresponding task.
spawnTaskUsingId :: MonadDES m => ProcessId m -> Process m a -> Process m (Task m a)
{-# INLINABLE spawnTaskUsingId #-}
spawnTaskUsingId :: forall (m :: * -> *) a.
MonadDES m =>
ProcessId m -> Process m a -> Process m (Task m a)
spawnTaskUsingId = forall (m :: * -> *) a.
MonadDES m =>
ContCancellation
-> ProcessId m -> Process m a -> Process m (Task m a)
spawnTaskUsingIdWith ContCancellation
CancelTogether

-- | Run a child process in background and return immediately the corresponding task.
spawnTask :: MonadDES m => Process m a -> Process m (Task m a)
{-# INLINABLE spawnTask #-}
spawnTask :: forall (m :: * -> *) a.
MonadDES m =>
Process m a -> Process m (Task m a)
spawnTask = forall (m :: * -> *) a.
MonadDES m =>
ContCancellation -> Process m a -> Process m (Task m a)
spawnTaskWith ContCancellation
CancelTogether

-- | Run using the specified identifier a child process in background and return
-- immediately the corresponding task.
spawnTaskUsingIdWith :: MonadDES m => ContCancellation -> ProcessId m -> Process m a -> Process m (Task m a)
{-# INLINABLE spawnTaskUsingIdWith #-}
spawnTaskUsingIdWith :: forall (m :: * -> *) a.
MonadDES m =>
ContCancellation
-> ProcessId m -> Process m a -> Process m (Task m a)
spawnTaskUsingIdWith ContCancellation
cancellation ProcessId m
pid Process m a
p =
  do (Task m a
t, Process m ()
m) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadDES m =>
ProcessId m -> Process m a -> Event m (Task m a, Process m ())
newTaskUsingId ProcessId m
pid Process m a
p
     forall (m :: * -> *).
MonadDES m =>
ContCancellation -> ProcessId m -> Process m () -> Process m ()
spawnProcessUsingIdWith ContCancellation
cancellation ProcessId m
pid Process m ()
m
     forall (m :: * -> *) a. Monad m => a -> m a
return Task m a
t

-- | Run a child process in background and return immediately the corresponding task.
spawnTaskWith :: MonadDES m => ContCancellation -> Process m a -> Process m (Task m a)
{-# INLINABLE spawnTaskWith #-}
spawnTaskWith :: forall (m :: * -> *) a.
MonadDES m =>
ContCancellation -> Process m a -> Process m (Task m a)
spawnTaskWith ContCancellation
cancellation Process m a
p =
  do ProcessId m
pid <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
SimulationLift t m =>
Simulation m a -> t m a
liftSimulation forall (m :: * -> *). MonadDES m => Simulation m (ProcessId m)
newProcessId
     forall (m :: * -> *) a.
MonadDES m =>
ContCancellation
-> ProcessId m -> Process m a -> Process m (Task m a)
spawnTaskUsingIdWith ContCancellation
cancellation ProcessId m
pid Process m a
p

-- | Return an outer process that behaves like the task itself, for example,
-- when the task is cancelled if the outer process is cancelled. 
taskProcess :: MonadDES m => Task m a -> Process m a
{-# INLINABLE taskProcess #-}
taskProcess :: forall (m :: * -> *) a. MonadDES m => Task m a -> Process m a
taskProcess Task m a
t =
  do TaskResult a
x <- forall (m :: * -> *) a b.
MonadDES m =>
Process m a -> Process m b -> Process m a
finallyProcess
          (forall (m :: * -> *) a.
MonadDES m =>
Task m a -> Process m (TaskResult a)
taskResult Task m a
t)
          (do ProcessId m
pid <- forall (m :: * -> *). MonadDES m => Process m (ProcessId m)
processId
              forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
                do Bool
cancelled <- forall (m :: * -> *). MonadDES m => ProcessId m -> Event m Bool
processCancelled ProcessId m
pid
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cancelled forall a b. (a -> b) -> a -> b
$
                     forall (m :: * -> *) a. MonadDES m => Task m a -> Event m ()
cancelTask Task m a
t)
     case TaskResult a
x of
       TaskCompleted a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return a
a
       TaskError SomeException
e -> forall (m :: * -> *) e a.
(MonadDES m, Exception e) =>
e -> Process m a
throwProcess SomeException
e
       TaskResult a
TaskCancelled -> forall (m :: * -> *) a. MonadDES m => Process m a
cancelProcess

-- | Return the result of two parallel tasks.
taskParallelResult :: MonadDES m => Task m a -> Task m a -> Process m (TaskResult a, Task m a)
{-# INLINABLE taskParallelResult #-}
taskParallelResult :: forall (m :: * -> *) a.
MonadDES m =>
Task m a -> Task m a -> Process m (TaskResult a, Task m a)
taskParallelResult Task m a
t1 Task m a
t2 =
  do Maybe (TaskResult a)
x1 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Task m a -> Ref m (Maybe (TaskResult a))
taskResultRef Task m a
t1)
     case Maybe (TaskResult a)
x1 of
       Just TaskResult a
x1 -> forall (m :: * -> *) a. Monad m => a -> m a
return (TaskResult a
x1, Task m a
t2)
       Maybe (TaskResult a)
Nothing ->
         do Maybe (TaskResult a)
x2 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadRef m => Ref m a -> Event m a
readRef (forall (m :: * -> *) a. Task m a -> Ref m (Maybe (TaskResult a))
taskResultRef Task m a
t2)
            case Maybe (TaskResult a)
x2 of
              Just TaskResult a
x2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (TaskResult a
x2, Task m a
t1)
              Maybe (TaskResult a)
Nothing ->
                do let s1 :: Signal m (Either (TaskResult a) b)
s1 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Task m a -> Signal m (TaskResult a)
taskResultReceived Task m a
t1
                       s2 :: Signal m (Either a (TaskResult a))
s2 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Task m a -> Signal m (TaskResult a)
taskResultReceived Task m a
t2
                   Either (TaskResult a) (TaskResult a)
x <- forall (m :: * -> *) a. MonadDES m => Signal m a -> Process m a
processAwait forall a b. (a -> b) -> a -> b
$ forall {b}. Signal m (Either (TaskResult a) b)
s1 forall a. Semigroup a => a -> a -> a
<> forall {a}. Signal m (Either a (TaskResult a))
s2
                   case Either (TaskResult a) (TaskResult a)
x of
                     Left TaskResult a
x1  -> forall (m :: * -> *) a. Monad m => a -> m a
return (TaskResult a
x1, Task m a
t2)
                     Right TaskResult a
x2 -> forall (m :: * -> *) a. Monad m => a -> m a
return (TaskResult a
x2, Task m a
t1) 

-- | Return an outer process for two parallel tasks returning the result of
-- the first finished task and the rest task in pair. 
taskParallelProcess :: MonadDES m => Task m a -> Task m a -> Process m (a, Task m a)
{-# INLINABLE taskParallelProcess #-}
taskParallelProcess :: forall (m :: * -> *) a.
MonadDES m =>
Task m a -> Task m a -> Process m (a, Task m a)
taskParallelProcess Task m a
t1 Task m a
t2 =
  do (TaskResult a
x, Task m a
t) <-
       forall (m :: * -> *) a b.
MonadDES m =>
Process m a -> Process m b -> Process m a
finallyProcess
       (forall (m :: * -> *) a.
MonadDES m =>
Task m a -> Task m a -> Process m (TaskResult a, Task m a)
taskParallelResult Task m a
t1 Task m a
t2)
       (do ProcessId m
pid <- forall (m :: * -> *). MonadDES m => Process m (ProcessId m)
processId
           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$
             do Bool
cancelled <- forall (m :: * -> *). MonadDES m => ProcessId m -> Event m Bool
processCancelled ProcessId m
pid
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cancelled forall a b. (a -> b) -> a -> b
$
                  do forall (m :: * -> *) a. MonadDES m => Task m a -> Event m ()
cancelTask Task m a
t1
                     forall (m :: * -> *) a. MonadDES m => Task m a -> Event m ()
cancelTask Task m a
t2)
     case TaskResult a
x of
       TaskCompleted a
a -> forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, Task m a
t)
       TaskError SomeException
e ->
         do forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Task m a -> Event m ()
cancelTask Task m a
t
            forall (m :: * -> *) e a.
(MonadDES m, Exception e) =>
e -> Process m a
throwProcess SomeException
e
       TaskResult a
TaskCancelled ->
         do forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadDES m => Task m a -> Event m ()
cancelTask Task m a
t
            forall (m :: * -> *) a. MonadDES m => Process m a
cancelProcess