content: 
  {-# LANGUAGE RecursiveDo, RankNTypes #-}
  
  -- |
  -- Module     : Simulation.Aivika.Internal.Event
  -- 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
  --
  -- This is an internal implementation module that should never be used directly.
  --
  -- The module defines the 'Event' monad which is very similar to the 'Dynamics'
  -- monad but only now the computation is strongly synchronized with the event queue.
  --
  -- The @Dynamics@ computation is defined in all time points simultaneously, while
  -- the @Event@ computation can be described in every time point differently and can change
  -- in discrete steps. Therefore, the former is destined for differential and difference
  -- equations of System Dynamics, while the latter is destined for discrete event simulation,
  -- being its core actually.
  --
  module Simulation.Aivika.Internal.Event
         (-- * Event Monad
          Event(..),
          EventLift(..),
          EventProcessing(..),
          invokeEvent,
          runEvent,
          runEventWith,
          runEventInStartTime,
          runEventInStopTime,
          -- * Event Queue
          enqueueEvent,
          enqueueEventWithCancellation,
          enqueueEventWithStartTime,
          enqueueEventWithStopTime,
          enqueueEventWithTimes,
          enqueueEventWithPoints,
          enqueueEventWithIntegTimes,
          yieldEvent,
          eventQueueCount,
          -- * Cancelling Event
          EventCancellation,
          cancelEvent,
          eventCancelled,
          eventFinished,
          -- * Error Handling
          catchEvent,
          finallyEvent,
          throwEvent,
          -- * Memoization
          memoEvent,
          memoEventInTime,
          -- * Disposable
          DisposableEvent(..),
          -- * Retrying Computation
          retryEvent,
          -- * Debugging
          traceEvent) where
  
  import Data.IORef
  import Data.Monoid hiding ((<>))
  import Data.Semigroup (Semigroup(..))
  
  import Control.Exception
  import Control.Monad
  import Control.Monad.Trans
  import Control.Monad.Fix
  import Control.Monad.Fail
  import qualified Control.Monad.Catch as MC
  import Control.Applicative
  
  import Debug.Trace (trace)
  
  import qualified Simulation.Aivika.PriorityQueue as PQ
  
  import Simulation.Aivika.Internal.Specs
  import Simulation.Aivika.Internal.Parameter
  import Simulation.Aivika.Internal.Simulation
  import Simulation.Aivika.Internal.Dynamics
  
  -- | A value in the 'Event' monad represents a polymorphic time varying function
  -- which is strongly synchronized with the event queue.
  newtype Event a = Event (Point -> IO a)
  
  instance Monad Event where
    return  = returnE
    m >>= k = bindE m k
  
  returnE :: a -> Event a
  {-# INLINE returnE #-}
  returnE a = Event (\p -> return a)
  
  bindE :: Event a -> (a -> Event b) -> Event b
  {-# INLINE bindE #-}
  bindE (Event m) k = 
    Event $ \p -> 
    do a <- m p
       let Event m' = k a
       m' p
  
  instance Functor Event where
    fmap = liftME
  
  instance Applicative Event where
    pure = return
    (<*>) = ap
  
  instance MonadFail Event where
    fail = error
  
  liftME :: (a -> b) -> Event a -> Event b
  {-# INLINE liftME #-}
  liftME f (Event x) =
    Event $ \p -> do { a <- x p; return $ f a }
  
  instance MonadIO Event where
    liftIO m = Event $ const m
  
  instance ParameterLift Event where
    liftParameter = liftPS
  
  instance SimulationLift Event where
    liftSimulation = liftES
  
  instance DynamicsLift Event where
    liftDynamics = liftDS
      
  liftPS :: Parameter a -> Event a
  {-# INLINE liftPS #-}
  liftPS (Parameter m) =
    Event $ \p -> m $ pointRun p
      
  liftES :: Simulation a -> Event a
  {-# INLINE liftES #-}
  liftES (Simulation m) =
    Event $ \p -> m $ pointRun p
  
  liftDS :: Dynamics a -> Event a
  {-# INLINE liftDS #-}
  liftDS (Dynamics m) =
    Event m
  
  -- | A type class to lift the 'Event' computation to other computations.
  class EventLift m where
    
    -- | Lift the specified 'Event' computation to another computation.
    liftEvent :: Event a -> m a
  
  instance EventLift Event where
    liftEvent = id
    
  -- | Exception handling within 'Event' computations.
  catchEvent :: Exception e => Event a -> (e -> Event a) -> Event a
  catchEvent (Event m) h =
    Event $ \p -> 
    catch (m p) $ \e ->
    let Event m' = h e in m' p
                             
  -- | A computation with finalization part like the 'finally' function.
  finallyEvent :: Event a -> Event b -> Event a
  finallyEvent (Event m) (Event m') =
    Event $ \p ->
    finally (m p) (m' p)
  
  -- | Like the standard 'throw' function.
  throwEvent :: Exception e => e -> Event a
  throwEvent = throw
  
  -- | Runs an action with asynchronous exceptions disabled.
  maskEvent :: ((forall a. Event a -> Event a) -> Event b) -> Event b
  maskEvent a =
    Event $ \p ->
    MC.mask $ \u ->
    invokeEvent p (a $ q u)
    where q u (Event b) = Event (u . b)
  
  -- | Like 'maskEvent', but the masked computation is not interruptible.
  uninterruptibleMaskEvent :: ((forall a. Event a -> Event a) -> Event b) -> Event b
  uninterruptibleMaskEvent a =
    Event $ \p ->
    MC.uninterruptibleMask $ \u ->
    invokeEvent p (a $ q u)
    where q u (Event b) = Event (u . b)
  
  -- | An implementation of 'generalBracket'.
  generalBracketEvent :: Event a
                         -> (a -> MC.ExitCase b -> Event c)
                         -> (a -> Event b)
                         -> Event (b, c)
  generalBracketEvent acquire release use =
    Event $ \p -> do
      MC.generalBracket
        (invokeEvent p acquire)
        (\resource e -> invokeEvent p $ release resource e)
        (\resource -> invokeEvent p $ use resource)
  
  -- | Invoke the 'Event' computation.
  invokeEvent :: Point -> Event a -> IO a
  {-# INLINE invokeEvent #-}
  invokeEvent p (Event m) = m p
  
  instance MonadFix Event where
    mfix f = 
      Event $ \p ->
      do { rec { a <- invokeEvent p (f a) }; return a }
  
  instance MC.MonadThrow Event where
    throwM = throwEvent
  
  instance MC.MonadCatch Event where
    catch = catchEvent
  
  instance MC.MonadMask Event where
    mask = maskEvent
    uninterruptibleMask = uninterruptibleMaskEvent
    generalBracket = generalBracketEvent
  
  -- | Defines how the events are processed.
  data EventProcessing = CurrentEvents
                         -- ^ either process all earlier and then current events,
                         -- or raise an error if the current simulation time is less
                         -- than the actual time of the event queue (safe within
                         -- the 'Event' computation as this is protected by the type system)
                       | EarlierEvents
                         -- ^ either process all earlier events not affecting
                         -- the events at the current simulation time,
                         -- or raise an error if the current simulation time is less
                         -- than the actual time of the event queue (safe within
                         -- the 'Event' computation as this is protected by the type system)
                       | CurrentEventsOrFromPast
                         -- ^ either process all earlier and then current events,
                         -- or do nothing if the current simulation time is less
                         -- than the actual time of the event queue
                         -- (do not use unless the documentation states the opposite)
                       | EarlierEventsOrFromPast
                         -- ^ either process all earlier events,
                         -- or do nothing if the current simulation time is less
                         -- than the actual time of the event queue
                         -- (do not use unless the documentation states the opposite)
                       deriving (Eq, Ord, Show)
  
  -- | Enqueue the event which must be actuated at the specified time.
  enqueueEvent :: Double -> Event () -> Event ()
  enqueueEvent t (Event m) =
    Event $ \p ->
    let pq = queuePQ $ runEventQueue $ pointRun p
    in PQ.enqueue pq t m
  
  -- | Process the pending events.
  processPendingEventsCore :: Bool -> Dynamics ()
  processPendingEventsCore includingCurrentEvents = Dynamics r where
    r p =
      do let q = runEventQueue $ pointRun p
             f = queueBusy q
         f' <- readIORef f
         unless f' $
           do writeIORef f True
              call q p
              writeIORef f False
    call q p =
      do let pq = queuePQ q
             r  = pointRun p
         f <- PQ.queueNull pq
         unless f $
           do (t2, c2) <- PQ.queueFront pq
              let t = queueTime q
              t' <- readIORef t
              when (t2 < t') $ 
                error "The time value is too small: processPendingEventsCore"
              when ((t2 < pointTime p) ||
                    (includingCurrentEvents && (t2 == pointTime p))) $
                do writeIORef t t2
                   PQ.dequeue pq
                   let sc = pointSpecs p
                       t0 = spcStartTime sc
                       dt = spcDT sc
                       n2 = fromIntegral $ floor ((t2 - t0) / dt)
                   c2 $ p { pointTime = t2,
                            pointIteration = n2,
                            pointPhase = -1 }
                   call q p
  
  -- | Process the pending events synchronously, i.e. without past.
  processPendingEvents :: Bool -> Dynamics ()
  processPendingEvents includingCurrentEvents = Dynamics r where
    r p =
      do let q = runEventQueue $ pointRun p
             t = queueTime q
         t' <- readIORef t
         if pointTime p < t'
           then error $
                "The current time is less than " ++
                "the time in the queue: processPendingEvents"
           else invokeDynamics p m
    m = processPendingEventsCore includingCurrentEvents
  
  -- | A memoized value.
  processEventsIncludingCurrent = processPendingEvents True
  
  -- | A memoized value.
  processEventsIncludingEarlier = processPendingEvents False
  
  -- | A memoized value.
  processEventsIncludingCurrentCore = processPendingEventsCore True
  
  -- | A memoized value.
  processEventsIncludingEarlierCore = processPendingEventsCore True
  
  -- | Process the events.
  processEvents :: EventProcessing -> Dynamics ()
  processEvents CurrentEvents = processEventsIncludingCurrent
  processEvents EarlierEvents = processEventsIncludingEarlier
  processEvents CurrentEventsOrFromPast = processEventsIncludingCurrentCore
  processEvents EarlierEventsOrFromPast = processEventsIncludingEarlierCore
  
  -- | Run the 'Event' computation in the current simulation time
  -- within the 'Dynamics' computation involving all pending
  -- 'CurrentEvents' in the processing too.
  runEvent :: Event a -> Dynamics a
  runEvent = runEventWith CurrentEvents
  
  -- | Run the 'Event' computation in the current simulation time
  -- within the 'Dynamics' computation specifying what pending events 
  -- should be involved in the processing.
  runEventWith :: EventProcessing -> Event a -> Dynamics a
  runEventWith processing (Event e) =
    Dynamics $ \p ->
    do invokeDynamics p $ processEvents processing
       e p
  
  -- | Run the 'Event' computation in the start time involving all
  -- pending 'CurrentEvents' in the processing too.
  runEventInStartTime :: Event a -> Simulation a
  runEventInStartTime = runDynamicsInStartTime . runEvent
  
  -- | Run the 'Event' computation in the stop time involving all
  -- pending 'CurrentEvents' in the processing too.
  runEventInStopTime :: Event a -> Simulation a
  runEventInStopTime = runDynamicsInStopTime . runEvent
  
  -- | Return the number of pending events that should
  -- be yet actuated.
  eventQueueCount :: Event Int
  eventQueueCount =
    Event $ PQ.queueCount . queuePQ . runEventQueue . pointRun
  
  -- | Actuate the event handler in the specified time points.
  enqueueEventWithTimes :: [Double] -> Event () -> Event ()
  enqueueEventWithTimes ts e = loop ts
    where loop []       = return ()
          loop (t : ts) = enqueueEvent t $ e >> loop ts
         
  -- | Actuate the event handler in the specified time points.
  enqueueEventWithPoints :: [Point] -> Event () -> Event ()
  enqueueEventWithPoints xs (Event e) = loop xs
    where loop []       = return ()
          loop (x : xs) = enqueueEvent (pointTime x) $ 
                          Event $ \p ->
                          do e x    -- N.B. we substitute the time point!
                             invokeEvent p $ loop xs
                             
  -- | Actuate the event handler in the integration time points.
  enqueueEventWithIntegTimes :: Event () -> Event ()
  enqueueEventWithIntegTimes e =
    Event $ \p ->
    let points = integPointsStartingFrom p
    in invokeEvent p $ enqueueEventWithPoints points e
  
  -- | Actuate the event handler in the start time point.
  enqueueEventWithStartTime :: Event () -> Event ()
  enqueueEventWithStartTime e =
    Event $ \p ->
    let p0 = integStartPoint $ pointRun p
    in invokeEvent p $ enqueueEventWithPoints [p0] e
  
  -- | Actuate the event handler in the final time point.
  enqueueEventWithStopTime :: Event () -> Event ()
  enqueueEventWithStopTime e =
    Event $ \p ->
    let p0 = simulationStopPoint $ pointRun p
    in invokeEvent p $ enqueueEventWithPoints [p0] e
  
  -- | It allows cancelling the event.
  data EventCancellation =
    EventCancellation { cancelEvent   :: Event (),
                        -- ^ Cancel the event.
                        eventCancelled :: Event Bool,
                        -- ^ Test whether the event was cancelled.
                        eventFinished :: Event Bool
                        -- ^ Test whether the event was processed and finished.
                      }
  
  -- | Enqueue the event with an ability to cancel it.
  enqueueEventWithCancellation :: Double -> Event () -> Event EventCancellation
  enqueueEventWithCancellation t e =
    Event $ \p ->
    do cancelledRef <- newIORef False
       cancellableRef <- newIORef True
       finishedRef <- newIORef False
       let cancel =
             Event $ \p ->
             do x <- readIORef cancellableRef
                when x $
                  writeIORef cancelledRef True
           cancelled =
             Event $ \p -> readIORef cancelledRef
           finished =
             Event $ \p -> readIORef finishedRef
       invokeEvent p $
         enqueueEvent t $
         Event $ \p ->
         do writeIORef cancellableRef False
            x <- readIORef cancelledRef
            unless x $
              do invokeEvent p e
                 writeIORef finishedRef True
       return EventCancellation { cancelEvent   = cancel,
                                  eventCancelled = cancelled,
                                  eventFinished = finished }
  
  -- | Memoize the 'Event' computation, always returning the same value
  -- within a simulation run.
  memoEvent :: Event a -> Simulation (Event a)
  memoEvent m =
    do ref <- liftIO $ newIORef Nothing
       return $ Event $ \p ->
         do x <- readIORef ref
            case x of
              Just v -> return v
              Nothing ->
                do v <- invokeEvent p m
                   writeIORef ref (Just v)
                   return v
  
  -- | Memoize the 'Event' computation, always returning the same value
  -- in the same modeling time. After the time changes, the value is
  -- recalculated by demand.
  --
  -- It is possible to implement this function efficiently, for the 'Event'
  -- computation is always synchronized with the event queue which time
  -- flows in one direction only. This synchronization is a key difference
  -- between the 'Event' and 'Dynamics' computations.
  memoEventInTime :: Event a -> Simulation (Event a)
  memoEventInTime m =
    do ref <- liftIO $ newIORef Nothing
       return $ Event $ \p ->
         do x <- readIORef ref
            case x of
              Just (t, v) | t == pointTime p ->
                return v
              _ ->
                do v <- invokeEvent p m
                   writeIORef ref (Just (pointTime p, v))
                   return v
  
  -- | Enqueue the event which must be actuated with the current modeling time but later.
  yieldEvent :: Event () -> Event ()
  yieldEvent m =
    Event $ \p ->
    invokeEvent p $
    enqueueEvent (pointTime p) m
  
  -- | Defines a computation disposing some entity.
  newtype DisposableEvent =
    DisposableEvent { disposeEvent :: Event ()
                      -- ^ Dispose something within the 'Event' computation.
                    }
  
  instance Semigroup DisposableEvent where
    DisposableEvent x <> DisposableEvent y = DisposableEvent $ x >> y
  
  instance Monoid DisposableEvent where
  
    mempty = DisposableEvent $ return ()
    mappend = (<>)
  
  -- | Retry the current computation as possible, using the specified argument
  -- as a 'SimulationRetry' exception message in case of failure.
  retryEvent :: String -> Event a
  retryEvent message = throwEvent $ SimulationRetry message
  
  -- | Show the debug message with the current simulation time.
  traceEvent :: String -> Event a -> Event a
  traceEvent message m =
    Event $ \p ->
    trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $
    invokeEvent p m
  