{-# LANGUAGE MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, RecursiveDo, MonoLocalBinds #-}

-- |
-- Module     : Simulation.Aivika.Trans.Composite
-- 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
--
-- It defines the 'Composite' monad transformer that allows constructing components which
-- can be then destroyed in case of need.
--
module Simulation.Aivika.Trans.Composite
       (-- * Composite Monad
        Composite,
        CompositeLift(..),
        runComposite,
        runComposite_,
        runCompositeInStartTime_,
        runCompositeInStopTime_,
        disposableComposite) where

import Data.Monoid

import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Fix
import Control.Monad.Fail
import Control.Applicative

import Simulation.Aivika.Trans.Comp
import Simulation.Aivika.Trans.DES
import Simulation.Aivika.Trans.Parameter
import Simulation.Aivika.Trans.Simulation
import Simulation.Aivika.Trans.Dynamics
import Simulation.Aivika.Trans.Event

-- | It represents a composite which can be then destroyed in case of need.
newtype Composite m a = Composite { Composite m a
-> DisposableEvent m -> Event m (a, DisposableEvent m)
runComposite :: DisposableEvent m -> Event m (a, DisposableEvent m)
                                    -- ^ Run the computation returning the result
                                    -- and some 'DisposableEvent' that being applied
                                    -- destroys the composite, for example, unsubscribes
                                    -- from signals or cancels the processes.
                                    --
                                  }

-- | Like 'runComposite' but retains the composite parts during the simulation.
runComposite_ :: Monad m => Composite m a -> Event m a
{-# INLINABLE runComposite_ #-}
runComposite_ :: Composite m a -> Event m a
runComposite_ Composite m a
m =
  do (a
a, DisposableEvent m
_) <- Composite m a
-> DisposableEvent m -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a.
Composite m a
-> DisposableEvent m -> Event m (a, DisposableEvent m)
runComposite Composite m a
m DisposableEvent m
forall a. Monoid a => a
mempty
     a -> Event m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

-- | Like 'runComposite_' but runs the computation in the start time.
runCompositeInStartTime_ :: MonadDES m => Composite m a -> Simulation m a
{-# INLINABLE runCompositeInStartTime_ #-}
runCompositeInStartTime_ :: Composite m a -> Simulation m a
runCompositeInStartTime_ = Event m a -> Simulation m a
forall (m :: * -> *) a. MonadDES m => Event m a -> Simulation m a
runEventInStartTime (Event m a -> Simulation m a)
-> (Composite m a -> Event m a) -> Composite m a -> Simulation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Composite m a -> Event m a
forall (m :: * -> *) a. Monad m => Composite m a -> Event m a
runComposite_

-- | Like 'runComposite_' but runs the computation in the stop time.
runCompositeInStopTime_ :: MonadDES m => Composite m a -> Simulation m a
{-# INLINABLE runCompositeInStopTime_ #-}
runCompositeInStopTime_ :: Composite m a -> Simulation m a
runCompositeInStopTime_ = Event m a -> Simulation m a
forall (m :: * -> *) a. MonadDES m => Event m a -> Simulation m a
runEventInStopTime (Event m a -> Simulation m a)
-> (Composite m a -> Event m a) -> Composite m a -> Simulation m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Composite m a -> Event m a
forall (m :: * -> *) a. Monad m => Composite m a -> Event m a
runComposite_

-- | When destroying the composite, the specified action will be applied.
disposableComposite :: Monad m => DisposableEvent m -> Composite m ()
{-# INLINABLE disposableComposite #-}
disposableComposite :: DisposableEvent m -> Composite m ()
disposableComposite DisposableEvent m
h = (DisposableEvent m -> Event m ((), DisposableEvent m))
-> Composite m ()
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m ((), DisposableEvent m))
 -> Composite m ())
-> (DisposableEvent m -> Event m ((), DisposableEvent m))
-> Composite m ()
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 -> ((), DisposableEvent m) -> Event m ((), DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return ((), DisposableEvent m
h0 DisposableEvent m -> DisposableEvent m -> DisposableEvent m
forall a. Semigroup a => a -> a -> a
<> DisposableEvent m
h)

instance Monad m => Functor (Composite m) where

  {-# INLINE fmap #-}
  fmap :: (a -> b) -> Composite m a -> Composite m b
fmap a -> b
f (Composite DisposableEvent m -> Event m (a, DisposableEvent m)
m) =
    (DisposableEvent m -> Event m (b, DisposableEvent m))
-> Composite m b
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (b, DisposableEvent m))
 -> Composite m b)
-> (DisposableEvent m -> Event m (b, DisposableEvent m))
-> Composite m b
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do (a
a, DisposableEvent m
h) <- DisposableEvent m -> Event m (a, DisposableEvent m)
m DisposableEvent m
h0
       (b, DisposableEvent m) -> Event m (b, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> b
f a
a, DisposableEvent m
h)

instance Monad m => Applicative (Composite m) where

  {-# INLINE pure #-}
  pure :: a -> Composite m a
pure = a -> Composite m a
forall (m :: * -> *) a. Monad m => a -> m a
return

  {-# INLINE (<*>) #-}
  <*> :: Composite m (a -> b) -> Composite m a -> Composite m b
(<*>) = Composite m (a -> b) -> Composite m a -> Composite m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (Composite m) where

  {-# INLINE return #-}
  return :: a -> Composite m a
return a
a = (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (a, DisposableEvent m))
 -> Composite m a)
-> (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 -> (a, DisposableEvent m) -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, DisposableEvent m
h0)

  {-# INLINE (>>=) #-}
  (Composite DisposableEvent m -> Event m (a, DisposableEvent m)
m) >>= :: Composite m a -> (a -> Composite m b) -> Composite m b
>>= a -> Composite m b
k =
    (DisposableEvent m -> Event m (b, DisposableEvent m))
-> Composite m b
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (b, DisposableEvent m))
 -> Composite m b)
-> (DisposableEvent m -> Event m (b, DisposableEvent m))
-> Composite m b
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do (a
a, DisposableEvent m
h) <- DisposableEvent m -> Event m (a, DisposableEvent m)
m DisposableEvent m
h0
       let Composite DisposableEvent m -> Event m (b, DisposableEvent m)
m' = a -> Composite m b
k a
a
       (b
b, DisposableEvent m
h') <- DisposableEvent m -> Event m (b, DisposableEvent m)
m' DisposableEvent m
h
       (b, DisposableEvent m) -> Event m (b, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (b
b, DisposableEvent m
h')

instance Monad m => MonadFail (Composite m) where

  {-# INLINE fail #-}
  fail :: String -> Composite m a
fail = String -> Composite m a
forall a. HasCallStack => String -> a
error

instance (Monad m, MonadIO (Event m)) => MonadIO (Composite m) where

  {-# INLINE liftIO #-}
  liftIO :: IO a -> Composite m a
liftIO IO a
m =
    (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (a, DisposableEvent m))
 -> Composite m a)
-> (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do a
a <- IO a -> Event m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
m
       (a, DisposableEvent m) -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, DisposableEvent m
h0)

instance (Monad m, MonadFix (Event m)) => MonadFix (Composite m) where

  {-# INLINABLE mfix #-}
  mfix :: (a -> Composite m a) -> Composite m a
mfix a -> Composite m a
f =
    (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (a, DisposableEvent m))
 -> Composite m a)
-> (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do rec (a
a, DisposableEvent m
h) <- Composite m a
-> DisposableEvent m -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a.
Composite m a
-> DisposableEvent m -> Event m (a, DisposableEvent m)
runComposite (a -> Composite m a
f a
a) DisposableEvent m
h0
       (a, DisposableEvent m) -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, DisposableEvent m
h)

instance MonadTrans Composite where

  {-# INLINE lift #-}
  lift :: m a -> Composite m a
lift m a
m =
    (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (a, DisposableEvent m))
 -> Composite m a)
-> (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do a
a <- m a -> Event m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m a
m
       (a, DisposableEvent m) -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, DisposableEvent m
h0)

instance Monad m => MonadCompTrans Composite m where

  {-# INLINE liftComp #-}
  liftComp :: m a -> Composite m a
liftComp m a
m =
    (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (a, DisposableEvent m))
 -> Composite m a)
-> (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do a
a <- m a -> Event m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
MonadCompTrans t m =>
m a -> t m a
liftComp m a
m
       (a, DisposableEvent m) -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, DisposableEvent m
h0)

instance Monad m => ParameterLift Composite m where

  {-# INLINE liftParameter #-}
  liftParameter :: Parameter m a -> Composite m a
liftParameter Parameter m a
m =
    (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (a, DisposableEvent m))
 -> Composite m a)
-> (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do a
a <- Parameter m a -> Event m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
ParameterLift t m =>
Parameter m a -> t m a
liftParameter Parameter m a
m
       (a, DisposableEvent m) -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, DisposableEvent m
h0)

instance Monad m => SimulationLift Composite m where

  {-# INLINE liftSimulation #-}
  liftSimulation :: Simulation m a -> Composite m a
liftSimulation Simulation m a
m =
    (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (a, DisposableEvent m))
 -> Composite m a)
-> (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do a
a <- Simulation m a -> Event m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
SimulationLift t m =>
Simulation m a -> t m a
liftSimulation Simulation m a
m
       (a, DisposableEvent m) -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, DisposableEvent m
h0)

instance Monad m => DynamicsLift Composite m where

  {-# INLINE liftDynamics #-}
  liftDynamics :: Dynamics m a -> Composite m a
liftDynamics Dynamics m a
m =
    (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (a, DisposableEvent m))
 -> Composite m a)
-> (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do a
a <- Dynamics m a -> Event m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
DynamicsLift t m =>
Dynamics m a -> t m a
liftDynamics Dynamics m a
m
       (a, DisposableEvent m) -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, DisposableEvent m
h0)

instance Monad m => EventLift Composite m where

  {-# INLINE liftEvent #-}
  liftEvent :: Event m a -> Composite m a
liftEvent Event m a
m =
    (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall (m :: * -> *) a.
(DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
Composite ((DisposableEvent m -> Event m (a, DisposableEvent m))
 -> Composite m a)
-> (DisposableEvent m -> Event m (a, DisposableEvent m))
-> Composite m a
forall a b. (a -> b) -> a -> b
$ \DisposableEvent m
h0 ->
    do a
a <- Event m a -> Event m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
EventLift t m =>
Event m a -> t m a
liftEvent Event m a
m
       (a, DisposableEvent m) -> Event m (a, DisposableEvent m)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, DisposableEvent m
h0)

-- | A type class to lift the 'Composite' computation to other computations.
class CompositeLift t m where
  
  -- | Lift the specified 'Composite' computation to another computation.
  liftComposite :: Composite m a -> t m a

instance Monad m => CompositeLift Composite m where

  {-# INLINE liftComposite #-}
  liftComposite :: Composite m a -> Composite m a
liftComposite = Composite m a -> Composite m a
forall a. a -> a
id