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

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)

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

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