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