aivika-transformers 2.1 → 3.0

raw patch · 22 files changed

+593/−41 lines, 22 filesdep ~aivikaPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aivika

API changes (from Hackage documentation)

Files

• Simulation/Aivika/Trans/Activity.hs +78/−9
• Simulation/Aivika/Trans/Circuit.hs +105/−4
• Simulation/Aivika/Trans/Dynamics.hs +3/−1
• Simulation/Aivika/Trans/Event.hs +3/−1
• Simulation/Aivika/Trans/Internal/Cont.hs +15/−1
• Simulation/Aivika/Trans/Internal/Dynamics.hs +12/−1
• Simulation/Aivika/Trans/Internal/Event.hs +13/−2
• Simulation/Aivika/Trans/Internal/Process.hs +10/−1
• Simulation/Aivika/Trans/Internal/Signal.hs +9/−1
• Simulation/Aivika/Trans/Internal/Simulation.hs +6/−1
• Simulation/Aivika/Trans/Internal/Specs.hs +17/−0
• Simulation/Aivika/Trans/Net.hs +46/−1
• Simulation/Aivika/Trans/Process.hs +3/−1
• Simulation/Aivika/Trans/Processor.hs +15/−1
• Simulation/Aivika/Trans/Results.hs +106/−2
• Simulation/Aivika/Trans/Results/Locale.hs +24/−0
• Simulation/Aivika/Trans/Server.hs +78/−8
• Simulation/Aivika/Trans/Signal.hs +3/−1
• Simulation/Aivika/Trans/Simulation.hs +4/−1
• Simulation/Aivika/Trans/Statistics.hs +15/−1
• Simulation/Aivika/Trans/Stream.hs +25/−1
• aivika-transformers.cabal +3/−2

@@ -12,8 +12,11 @@ module Simulation.Aivika.Trans.Activity        (-- * Activity         Activity,+        ActivityInterruption(..),         newActivity,         newStateActivity,+        newInterruptibleActivity,+        newInterruptibleStateActivity,         -- * Processing         activityNet,         -- * Activity Properties@@ -45,11 +48,13 @@         -- * Basic Signals         activityUtilising,         activityUtilised,+        activityInterrupted,         -- * Overall Signal         activityChanged_) where  import Data.Monoid +import Control.Monad import Control.Monad.Trans import Control.Arrow @@ -69,6 +74,8 @@ import Simulation.Aivika.Trans.Server import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Activity (ActivityInterruption(..))+ -- | Like 'Server' it models an activity that takes @a@ and provides @b@ having state @s@. -- But unlike the former the activity is destined for simulation within 'Net' computation. data Activity m s a b =@@ -78,6 +85,8 @@              -- ^ The current state of the activity.              activityProcess :: s -> a -> Process m (s, b),              -- ^ Provide @b@ by specified @a@.+             activityProcessInterruptible :: Bool,+             -- ^ Whether the process is interruptible.              activityTotalUtilisationTimeRef :: ProtoRef m Double,              -- ^ The counted total time of utilising the activity.              activityTotalIdleTimeRef :: ProtoRef m Double,@@ -88,22 +97,29 @@              -- ^ The statistics for the time, when the activity was idle.              activityUtilisingSource :: SignalSource m a,              -- ^ A signal raised when starting to utilise the activity.-             activityUtilisedSource :: SignalSource m (a, b)+             activityUtilisedSource :: SignalSource m (a, b),              -- ^ A signal raised when the activity has been utilised.+             activityInterruptedSource :: SignalSource m (ActivityInterruption a)+             -- ^ A signal raised when the utilisation was interrupted.            }  -- | Create a new activity that can provide output @b@ by input @a@.+--+-- By default, it is assumed that the activity utilisation cannot be interrupted,+-- because the handling of possible task interruption is rather costly+-- operation. newActivity :: MonadComp m                => (a -> Process m b)                -- ^ provide an output by the specified input                -> Simulation m (Activity m () a b)-newActivity provide =-  flip newStateActivity () $ \s a ->-  do b <- provide a-     return (s, b)+newActivity = newInterruptibleActivity False  -- | Create a new activity that can provide output @b@ by input @a@ -- starting from state @s@.+--+-- By default, it is assumed that the activity utilisation cannot be interrupted,+-- because the handling of possible task interruption is rather costly+-- operation. newStateActivity :: MonadComp m                     => (s -> a -> Process m (s, b))                     -- ^ provide a new state and output by the specified @@ -111,7 +127,32 @@                     -> s                     -- ^ the initial state                     -> Simulation m (Activity m s a b)-newStateActivity provide state =+newStateActivity = newInterruptibleStateActivity False++-- | Create a new interruptible activity that can provide output @b@ by input @a@.+newInterruptibleActivity :: MonadComp m+                            => Bool+                            -- ^ whether the activity can be interrupted+                            -> (a -> Process m b)+                            -- ^ provide an output by the specified input+                            -> Simulation m (Activity m () a b)+newInterruptibleActivity interruptible provide =+  flip (newInterruptibleStateActivity interruptible) () $ \s a ->+  do b <- provide a+     return (s, b)++-- | Create a new activity that can provide output @b@ by input @a@+-- starting from state @s@.+newInterruptibleStateActivity :: MonadComp m+                                 => Bool+                                 -- ^ whether the activity can be interrupted+                                 -> (s -> a -> Process m (s, b))+                                 -- ^ provide a new state and output by the specified +                                 -- old state and input+                                 -> s+                                 -- ^ the initial state+                                 -> Simulation m (Activity m s a b)+newInterruptibleStateActivity interruptible provide state =   do sn <- liftParameter simulationSession      r0 <- liftComp $ newProtoRef sn state      r1 <- liftComp $ newProtoRef sn 0@@ -120,15 +161,18 @@      r4 <- liftComp $ newProtoRef sn emptySamplingStats      s1 <- newSignalSource      s2 <- newSignalSource+     s3 <- newSignalSource      return Activity { activityInitState = state,                        activityStateRef = r0,                        activityProcess = provide,+                       activityProcessInterruptible = interruptible,                        activityTotalUtilisationTimeRef = r1,                        activityTotalIdleTimeRef = r2,                        activityUtilisationTimeRef = r3,                        activityIdleTimeRef = r4,                        activityUtilisingSource = s1,-                       activityUtilisedSource = s2 }+                       activityUtilisedSource = s2,+                       activityInterruptedSource = s3 }  -- | Return a network computation for the specified activity. --@@ -158,7 +202,9 @@                        addSamplingStats (t0 - t')               triggerSignal (activityUtilisingSource act) a          -- utilise the activity-         (s', b) <- activityProcess act s a+         (s', b) <- if activityProcessInterruptible act+                    then activityProcessInterrupting act s a+                    else activityProcess act s a          t1 <- liftDynamics time          liftEvent $            do liftComp $@@ -169,6 +215,24 @@               triggerSignal (activityUtilisedSource act) (a, b)          return (b, Net $ loop s' (Just t1)) +-- | Process the input with ability to handle a possible interruption.+activityProcessInterrupting :: MonadComp m => Activity m s a b -> s -> a -> Process m (s, b)+activityProcessInterrupting act s a =+  do pid <- processId+     t0  <- liftDynamics time+     finallyProcess+       (activityProcess act s a)+       (liftEvent $+        do cancelled <- processCancelled pid+           when cancelled $+             do t1 <- liftDynamics time+                liftComp $+                  do modifyProtoRef' (activityTotalUtilisationTimeRef act) (+ (t1 - t0))+                     modifyProtoRef' (activityUtilisationTimeRef act) $+                       addSamplingStats (t1 - t0)+                let x = ActivityInterruption a t0 t1+                triggerSignal (activityInterruptedSource act) x)+ -- | Return the current state of the activity. -- -- See also 'activityStateChanged' and 'activityStateChanged_'.@@ -336,11 +400,16 @@ activityUtilised :: Activity m s a b -> Signal m (a, b) activityUtilised = publishSignal . activityUtilisedSource +-- | Raised when the task utilisation by the activity was interrupted.+activityInterrupted :: Activity m s a b -> Signal m (ActivityInterruption a)+activityInterrupted = publishSignal . activityInterruptedSource+ -- | Signal whenever any property of the activity changes. activityChanged_ :: MonadComp m => Activity m s a b -> Signal m () activityChanged_ act =   mapSignal (const ()) (activityUtilising act) <>-  mapSignal (const ()) (activityUtilised act)+  mapSignal (const ()) (activityUtilised act) <>+  mapSignal (const ()) (activityInterrupted act)  -- | Return the summary for the activity with desciption of its -- properties using the specified indent.

@@ -20,8 +20,12 @@         Circuit(..),         iterateCircuitInIntegTimes,         iterateCircuitInIntegTimes_,+        iterateCircuitInIntegTimesMaybe,+        iterateCircuitInIntegTimesEither,         iterateCircuitInTimes,         iterateCircuitInTimes_,+        iterateCircuitInTimesMaybe,+        iterateCircuitInTimesEither,         -- * Circuit Primitives         arrCircuit,         accumCircuit,@@ -46,7 +50,9 @@         sumCircuit,         sumCircuitEither,         -- * The Circuit Transform-        circuitTransform) where+        circuitTransform,+        -- * Debugging+        traceCircuit) where  import qualified Control.Category as C import Control.Arrow@@ -463,14 +469,15 @@            do (a', cir') <- invokeEvent p $ runCircuit cir a               invokeEvent p $ loop ps cir' a' source      source <- liftSimulation newSignalSource+     task <- runTask $ processAwait $ publishSignal source      loop ps cir a source-     runTask $ processAwait $ publishSignal source+     return task  -- | Iterate the circuit in the integration time points. iterateCircuitInIntegTimes_ :: MonadComp m => Circuit m a a -> a -> Event m () iterateCircuitInIntegTimes_ cir a =   Event $ \p ->-  do let ps = integPoints $ pointRun p+  do let ps = integPointsStartingFrom p      invokeEvent p $         iterateCircuitInPoints_ ps cir a @@ -487,7 +494,7 @@ iterateCircuitInIntegTimes :: MonadComp m => Circuit m a a -> a -> Event m (Task m a) iterateCircuitInIntegTimes cir a =   Event $ \p ->-  do let ps = integPoints $ pointRun p+  do let ps = integPointsStartingFrom p      invokeEvent p $         iterateCircuitInPoints ps cir a @@ -499,3 +506,97 @@   do let ps = map (pointAt $ pointRun p) ts      invokeEvent p $         iterateCircuitInPoints ps cir a ++-- | Iterate the circuit in the specified time points, interrupting the iteration+-- immediately if 'Nothing' is returned within the 'Circuit' computation.+iterateCircuitInPointsMaybe :: MonadComp m => [Point m] -> Circuit m a (Maybe a) -> a -> Event m ()+iterateCircuitInPointsMaybe [] cir a = return ()+iterateCircuitInPointsMaybe (p : ps) cir a =+  enqueueEvent (pointTime p) $+  Event $ \p' ->+  do (a', cir') <- invokeEvent p $ runCircuit cir a+     case a' of+       Nothing -> return ()+       Just a' ->+         invokeEvent p $ iterateCircuitInPointsMaybe ps cir' a'++-- | Iterate the circuit in the integration time points, interrupting the iteration+-- immediately if 'Nothing' is returned within the 'Circuit' computation.+iterateCircuitInIntegTimesMaybe :: MonadComp m => Circuit m a (Maybe a) -> a -> Event m ()+iterateCircuitInIntegTimesMaybe cir a =+  Event $ \p ->+  do let ps = integPointsStartingFrom p+     invokeEvent p $ +       iterateCircuitInPointsMaybe ps cir a++-- | Iterate the circuit in the specified time points, interrupting the iteration+-- immediately if 'Nothing' is returned within the 'Circuit' computation.+iterateCircuitInTimesMaybe :: MonadComp m => [Double] -> Circuit m a (Maybe a) -> a -> Event m ()+iterateCircuitInTimesMaybe ts cir a =+  Event $ \p ->+  do let ps = map (pointAt $ pointRun p) ts+     invokeEvent p $ +       iterateCircuitInPointsMaybe ps cir a++-- | Iterate the circuit in the specified time points returning a task+-- that computes the final output of the circuit either after all points+-- are exhausted, or after the 'Left' result of type @b@ is received,+-- which interrupts the computation immediately.+iterateCircuitInPointsEither :: MonadComp m => [Point m] -> Circuit m a (Either b a) -> a -> Event m (Task m (Either b a))+iterateCircuitInPointsEither ps cir a =+  do let loop [] cir ba source = triggerSignal source ba+         loop ps cir ba@(Left b) source = triggerSignal source ba +         loop (p : ps) cir (Right a) source =+           enqueueEvent (pointTime p) $+           Event $ \p' ->+           do (ba', cir') <- invokeEvent p $ runCircuit cir a+              invokeEvent p $ loop ps cir' ba' source+     source <- liftSimulation newSignalSource+     task <- runTask $ processAwait $ publishSignal source+     loop ps cir (Right a) source+     return task++-- | Iterate the circuit in the integration time points returning a task+-- that computes the final output of the circuit either after all points+-- are exhausted, or after the 'Left' result of type @b@ is received,+-- which interrupts the computation immediately.+iterateCircuitInIntegTimesEither :: MonadComp m => Circuit m a (Either b a) -> a -> Event m (Task m (Either b a))+iterateCircuitInIntegTimesEither cir a =+  Event $ \p ->+  do let ps = integPointsStartingFrom p+     invokeEvent p $ +       iterateCircuitInPointsEither ps cir a++-- | Iterate the circuit in the specified time points returning a task+-- that computes the final output of the circuit either after all points+-- are exhausted, or after the 'Left' result of type @b@ is received,+-- which interrupts the computation immediately.+iterateCircuitInTimesEither :: MonadComp m => [Double] -> Circuit m a (Either b a) -> a -> Event m (Task m (Either b a))+iterateCircuitInTimesEither ts cir a =+  Event $ \p ->+  do let ps = map (pointAt $ pointRun p) ts+     invokeEvent p $ +       iterateCircuitInPointsEither ps cir a++-- | Show the debug messages with the current simulation time.+traceCircuit :: MonadComp m+                => Maybe String+                -- ^ the request message+                -> Maybe String+                -- ^ the response message+                -> Circuit m a b+                -- ^ a circuit+                -> Circuit m a b+traceCircuit request response cir = Circuit $ loop cir where+  loop cir a =+    do (b, cir') <-+         case request of+           Nothing -> runCircuit cir a+           Just message -> +             traceEvent message $+             runCircuit cir a+       case response of+         Nothing -> return (b, Circuit $ loop cir')+         Just message ->+           traceEvent message $+           return (b, Circuit $ loop cir') 

@@ -26,7 +26,9 @@         time,         isTimeInteg,         integIteration,-        integPhase) where+        integPhase,+        -- * Debugging+        traceDynamics) where  import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Dynamics

@@ -36,7 +36,9 @@         memoEvent,         memoEventInTime,         -- * Disposable-        DisposableEvent(..)) where+        DisposableEvent(..),+        -- * Debugging+        traceEvent) where  import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Event

@@ -35,7 +35,8 @@         resumeECont,         contCanceled,         contFreeze,-        contAwait) where+        contAwait,+        traceCont) where  import Data.Array import Data.Monoid@@ -45,6 +46,8 @@ import Control.Monad.Trans import Control.Applicative +import Debug.Trace (trace)+ import Simulation.Aivika.Trans.Session import Simulation.Aivika.Trans.ProtoRef import Simulation.Aivika.Trans.ProtoArray@@ -685,3 +688,14 @@                                   Just c  ->                                     invokeEvent p $ resumeCont c a      writeProtoRef r $ Just h          ++-- | Show the debug message with the current simulation time.+traceCont :: MonadComp m => String -> Cont m a -> Cont m a+traceCont message (Cont m) =+  Cont $ \c ->+  Event $ \p ->+  do z <- contCanceled c+     if z+       then cancelCont p c+       else trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $+            invokeEvent p $ m c

@@ -27,7 +27,9 @@         time,         isTimeInteg,         integIteration,-        integPhase) where+        integPhase,+        -- * Debugging+        traceDynamics) where  import Control.Exception import Control.Monad@@ -35,6 +37,8 @@ import Control.Monad.Fix import Control.Applicative +import Debug.Trace (trace)+ import Simulation.Aivika.Trans.Exception import Simulation.Aivika.Trans.Comp import Simulation.Aivika.Trans.Internal.Specs@@ -268,3 +272,10 @@ integPhase :: Monad m => Dynamics m Int {-# INLINE integPhase #-} integPhase = Dynamics $ return . pointPhase++-- | Show the debug message with the current simulation time.+traceDynamics :: Monad m => String -> Dynamics m a -> Dynamics m a+traceDynamics message m =+  Dynamics $ \p ->+  trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $+  invokeDynamics p m

@@ -36,7 +36,9 @@         memoEvent,         memoEventInTime,         -- * Disposable-        DisposableEvent(..)) where+        DisposableEvent(..),+        -- * Debugging+        traceEvent) where  import Data.Monoid @@ -46,6 +48,8 @@ import Control.Monad.Fix import Control.Applicative +import Debug.Trace (trace)+ import Simulation.Aivika.Trans.Exception import Simulation.Aivika.Trans.Session import Simulation.Aivika.Trans.ProtoRef@@ -174,7 +178,7 @@ enqueueEventWithIntegTimes :: MonadComp m => Event m () -> Event m () enqueueEventWithIntegTimes e =   Event $ \p ->-  let points = integPoints $ pointRun p+  let points = integPointsStartingFrom p   in invokeEvent p $ enqueueEventWithPoints points e  -- | It allows cancelling the event.@@ -275,3 +279,10 @@    {-# INLINE mappend #-}   mappend (DisposableEvent x) (DisposableEvent y) = DisposableEvent $ x >> y++-- | Show the debug message with the current simulation time.+traceEvent :: MonadComp m => String -> Event m a -> Event m a+traceEvent message m =+  Event $ \p ->+  trace ("t = " ++ show (pointTime p) ++ ": " ++ message) $+  invokeEvent p m

@@ -77,7 +77,9 @@         -- * Memoizing Process         memoProcess,         -- * Never Ending Process-        neverProcess) where+        neverProcess,+        -- * Debugging+        traceProcess) where  import Data.Maybe @@ -651,3 +653,10 @@   let signal = processCancelling pid   in handleSignal_ signal $ \_ ->      resumeCont c $ error "It must never be computed: neverProcess"++-- | Show the debug message with the current simulation time.+traceProcess :: MonadComp m => String -> Process m a -> Process m a+traceProcess message m =+  Process $ \pid ->+  traceCont message $+  invokeProcess pid m

@@ -49,7 +49,9 @@         Signalable(..),         signalableChanged,         emptySignalable,-        appendSignalable) where+        appendSignalable,+        -- * Debugging+        traceSignal) where  import Data.Monoid import Data.List@@ -394,3 +396,9 @@                                      case t0 of                                        Nothing -> Nothing                                        Just t0 -> Just (t - t0) } }++-- | Show the debug message with the current simulation time.+traceSignal :: MonadComp m => String -> Signal m a -> Signal m a +traceSignal message m =+  Signal { handleSignal = \h ->+            handleSignal m $ traceEvent message . h }

@@ -22,7 +22,10 @@         finallySimulation,         throwSimulation,         -- * Memoization-        memoSimulation) where+        memoSimulation,+        -- * Exceptions+        SimulationException(..),+        SimulationAbort(..)) where  import Control.Exception import Control.Monad@@ -37,6 +40,8 @@ import Simulation.Aivika.Trans.Comp import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Parameter++import Simulation.Aivika.Simulation (SimulationException, SimulationAbort)  instance Monad m => Monad (Simulation m) where 

@@ -34,6 +34,7 @@         integPhaseLoBnd,         integTimes,         integPoints,+        integPointsStartingFrom,         integStartPoint,         integStopPoint,         pointAt) where@@ -293,3 +294,19 @@                     pointTime = t,                     pointIteration = n,                     pointPhase = -1 }++-- | Return the integration time points startin from the specified iteration.+integPointsStartingFrom :: Point m -> [Point m]+integPointsStartingFrom p = points+  where r  = pointRun p+        sc = runSpecs r+        (nl, nu) = integIterationBnds sc+        n0       = if pointPhase p == 0+                   then pointIteration p+                   else pointIteration p + 1+        points   = map point [n0 .. nu]+        point n  = Point { pointSpecs = sc,+                           pointRun = r,+                           pointTime = basicTime sc n 0,+                           pointIteration = n,+                           pointPhase = 0 }

@@ -28,6 +28,8 @@        (-- * Net Arrow         Net(..),         iterateNet,+        iterateNetMaybe,+        iterateNetEither,         -- * Net Primitives         emptyNet,         arrNet,@@ -40,7 +42,9 @@         delayNet,         -- * Interchanging Nets with Processors         netProcessor,-        processorNet) where+        processorNet,+        -- * Debugging+        traceNet) where  import qualified Control.Category as C import Control.Arrow@@ -250,3 +254,44 @@ iterateNet (Net f) a =   do (a', x) <- f a      iterateNet x a'++-- | Iterate the net using the specified initial value+-- until 'Nothing' is returned within the 'Net' computation.+iterateNetMaybe :: MonadComp m => Net m a (Maybe a) -> a -> Process m ()+iterateNetMaybe (Net f) a =+  do (a', x) <- f a+     case a' of+       Nothing -> return ()+       Just a' -> iterateNetMaybe x a'++-- | Iterate the net using the specified initial value+-- until the 'Left' result is returned within the 'Net' computation.+iterateNetEither :: MonadComp m => Net m a (Either b a) -> a -> Process m b+iterateNetEither (Net f) a =+  do (ba', x) <- f a+     case ba' of+       Left b'  -> return b'+       Right a' -> iterateNetEither x a'++-- | Show the debug messages with the current simulation time.+traceNet :: MonadComp m+            => Maybe String+            -- ^ the request message+            -> Maybe String+            -- ^ the response message+            -> Net m a b+            -- ^ a net+            -> Net m a b+traceNet request response x = Net $ loop x where+  loop x a =+    do (b, x') <-+         case request of+           Nothing -> runNet x a+           Just message -> +             traceProcess message $+             runNet x a+       case response of+         Nothing -> return (b, Net $ loop x')+         Just message ->+           traceProcess message $+           return (b, Net $ loop x') 

@@ -79,6 +79,8 @@         -- * Memoizing Process         memoProcess,         -- * Never Ending Process-        neverProcess) where+        neverProcess,+        -- * Debugging+        traceProcess) where  import Simulation.Aivika.Trans.Internal.Process

@@ -43,7 +43,9 @@         arrivalProcessor,         -- * Integrating with Signals         signalProcessor,-        processorSignaling) where+        processorSignaling,+        -- * Debugging+        traceProcessor) where  import qualified Control.Category as C import Control.Arrow@@ -472,3 +474,15 @@ -- | A processor that delays the input stream by one step using the specified initial value. delayProcessor :: MonadComp m => a -> Processor m a a delayProcessor a0 = Processor $ delayStream a0++-- | Show the debug messages with the current simulation time.+traceProcessor :: MonadComp m+                  => Maybe String+                  -- ^ the request message+                  -> Maybe String+                  -- ^ the response message+                  -> Processor m a b+                  -- ^ a processor+                  -> Processor m a b+traceProcessor request response (Processor f) =+  Processor $ traceStream request response . f 

@@ -1480,6 +1480,90 @@                             -> ResultSource m timingStatsResultSummary = ResultItemSource . ResultItem . resultItemToStringValue   +-- | Return a source by the specified counter.+samplingCounterResultSource :: (MonadComp m,+                                ResultItemable (ResultValue a),+                                ResultItemable (ResultValue (SamplingStats a)))+                               => ResultValue (SamplingCounter a) m+                               -- ^ the counter+                               -> ResultSource m+samplingCounterResultSource x =+  ResultObjectSource $+  ResultObject {+    resultObjectName      = resultValueName x,+    resultObjectId        = resultValueId x,+    resultObjectTypeId    = SamplingCounterId,+    resultObjectSignal    = resultValueSignal x,+    resultObjectSummary   = samplingCounterResultSummary x,+    resultObjectProperties = [+      resultContainerMapProperty c "value" SamplingCounterValueId samplingCounterValue,+      resultContainerMapProperty c "stats" SamplingCounterStatsId samplingCounterStats ] }+  where+    c = resultValueToContainer x+      +-- | Return a source by the specified counter.+samplingCounterResultSummary :: (MonadComp m,+                                 ResultItemable (ResultValue a),+                                 ResultItemable (ResultValue (SamplingStats a)))+                                => ResultValue (SamplingCounter a) m+                                -- ^ the counter+                                -> ResultSource m+samplingCounterResultSummary x =+  ResultObjectSource $+  ResultObject {+    resultObjectName      = resultValueName x,+    resultObjectId        = resultValueId x,+    resultObjectTypeId    = SamplingCounterId,+    resultObjectSignal    = resultValueSignal x,+    resultObjectSummary   = samplingCounterResultSummary x,+    resultObjectProperties = [+      resultContainerMapProperty c "value" SamplingCounterValueId samplingCounterValue,+      resultContainerMapProperty c "stats" SamplingCounterStatsId samplingCounterStats ] }+  where+    c = resultValueToContainer x+      +-- | Return a source by the specified counter.+timingCounterResultSource :: (MonadComp m,+                              ResultItemable (ResultValue a),+                              ResultItemable (ResultValue (TimingStats a)))+                             => ResultValue (TimingCounter a) m+                             -- ^ the counter+                             -> ResultSource m+timingCounterResultSource x =+  ResultObjectSource $+  ResultObject {+    resultObjectName      = resultValueName x,+    resultObjectId        = resultValueId x,+    resultObjectTypeId    = TimingCounterId,+    resultObjectSignal    = resultValueSignal x,+    resultObjectSummary   = timingCounterResultSummary x,+    resultObjectProperties = [+      resultContainerMapProperty c "value" TimingCounterValueId timingCounterValue,+      resultContainerMapProperty c "stats" TimingCounterStatsId timingCounterStats ] }+  where+    c = resultValueToContainer x+      +-- | Return a source by the specified counter.+timingCounterResultSummary :: (MonadComp m,+                               ResultItemable (ResultValue a),+                               ResultItemable (ResultValue (TimingStats a)))+                              => ResultValue (TimingCounter a) m+                              -- ^ the counter+                              -> ResultSource m+timingCounterResultSummary x =+  ResultObjectSource $+  ResultObject {+    resultObjectName      = resultValueName x,+    resultObjectId        = resultValueId x,+    resultObjectTypeId    = TimingCounterId,+    resultObjectSignal    = resultValueSignal x,+    resultObjectSummary   = timingCounterResultSummary x,+    resultObjectProperties = [+      resultContainerMapProperty c "value" TimingCounterValueId timingCounterValue,+      resultContainerMapProperty c "stats" TimingCounterStatsId timingCounterStats ] }+  where+    c = resultValueToContainer x+   -- | Return a source by the specified finite queue. queueResultSource :: (MonadComp m,                       Show si, Show sm, Show so,@@ -1704,7 +1788,7 @@       resultContainerProperty c "utilisationTime" ActivityUtilisationTimeId activityUtilisationTime activityUtilisationTimeChanged_,       resultContainerProperty c "idleTime" ActivityIdleTimeId activityIdleTime activityIdleTimeChanged_,       resultContainerProperty c "utilisationFactor" ActivityUtilisationFactorId activityUtilisationFactor activityUtilisationFactorChanged_,-      resultContainerProperty c "idleFactor" ActivityIdleTimeId activityIdleFactor activityIdleFactorChanged_ ] }+      resultContainerProperty c "idleFactor" ActivityIdleFactorId activityIdleFactor activityIdleFactorChanged_ ] }  -- | Return a summary by the specified activity. activityResultSummary :: MonadComp m@@ -1723,7 +1807,7 @@       resultContainerProperty c "utilisationTime" ActivityUtilisationTimeId activityUtilisationTime activityUtilisationTimeChanged_,       resultContainerProperty c "idleTime" ActivityIdleTimeId activityIdleTime activityIdleTimeChanged_,       resultContainerProperty c "utilisationFactor" ActivityUtilisationFactorId activityUtilisationFactor activityUtilisationFactorChanged_,-      resultContainerProperty c "idleFactor" ActivityIdleTimeId activityIdleFactor activityIdleFactorChanged_ ] }+      resultContainerProperty c "idleFactor" ActivityIdleFactorId activityIdleFactor activityIdleFactorChanged_ ] }  -- | Return an arbitrary text as a separator source. textResultSource :: String -> ResultSource m@@ -1759,6 +1843,16 @@   resultSource' name i m =     ResultItemSource $ ResultItem $ computeResultValue name i m +instance ResultComputing t m => ResultProvider (t m (SamplingCounter Double)) m where++  resultSource' name i m =+    samplingCounterResultSource $ computeResultValue name i m++instance ResultComputing t m => ResultProvider (t m (TimingCounter Double)) m where++  resultSource' name i m =+    timingCounterResultSource $ computeResultValue name i m+ instance ResultComputing t m => ResultProvider (t m Int) m where    resultSource' name i m =@@ -1778,6 +1872,16 @@    resultSource' name i m =     ResultItemSource $ ResultItem $ computeResultValue name i m++instance ResultComputing t m => ResultProvider (t m (SamplingCounter Int)) m where++  resultSource' name i m =+    samplingCounterResultSource $ computeResultValue name i m++instance ResultComputing t m => ResultProvider (t m (TimingCounter Int)) m where++  resultSource' name i m =+    timingCounterResultSource $ computeResultValue name i m  instance ResultComputing t m => ResultProvider (t m String) m where 

@@ -69,6 +69,12 @@                 -- ^ Property 'samplingStatsVariance'.               | SamplingStatsDeviationId                 -- ^ Property 'samplingStatsDeviation'.+              | SamplingCounterId+                -- ^ A 'SamplingCounter' value.+              | SamplingCounterValueId+                -- ^ Property 'samplingCounterValue'.+              | SamplingCounterStatsId+                -- ^ Property 'samplingCounterStats'.               | TimingStatsId                 -- ^ A 'TimingStats' value.               | TimingStatsCountId@@ -95,6 +101,12 @@                 -- ^ Property 'timingStatsSum'.               | TimingStatsSum2Id                 -- ^ Property 'timingStatsSum2'.+              | TimingCounterId+                -- ^ A 'TimingCounter' value.+              | TimingCounterValueId+                -- ^ Property 'timingCounterValue'.+              | TimingCounterStatsId+                -- ^ Property 'timingCounterStats'.               | FiniteQueueId                 -- ^ A finite 'Q.Queue'.               | InfiniteQueueId@@ -231,6 +243,12 @@ russianResultLocalisation TimingStatsLastTimeId = "конечное время сбора статистики" russianResultLocalisation TimingStatsSumId = "сумма" russianResultLocalisation TimingStatsSum2Id = "сумма квадратов"+russianResultLocalisation SamplingCounterId = "счетчик"+russianResultLocalisation SamplingCounterValueId = "текущее значение"+russianResultLocalisation SamplingCounterStatsId = "статистика"+russianResultLocalisation TimingCounterId = "временной счетчик"+russianResultLocalisation TimingCounterValueId = "текущее значение"+russianResultLocalisation TimingCounterStatsId = "статистика" russianResultLocalisation FiniteQueueId = "конечная очередь" russianResultLocalisation InfiniteQueueId = "бесконечная очередь" russianResultLocalisation EnqueueStrategyId = "стратегия добавления элементов"@@ -309,6 +327,12 @@ englishResultLocalisation TimingStatsLastTimeId = "the last time" englishResultLocalisation TimingStatsSumId = "sum" englishResultLocalisation TimingStatsSum2Id = "sum square"+englishResultLocalisation SamplingCounterId = "counter"+englishResultLocalisation SamplingCounterValueId = "current value"+englishResultLocalisation SamplingCounterStatsId = "statistics"+englishResultLocalisation TimingCounterId = "timing counter"+englishResultLocalisation TimingCounterValueId = "current value"+englishResultLocalisation TimingCounterStatsId = "statistics" englishResultLocalisation FiniteQueueId = "the finite queue" englishResultLocalisation InfiniteQueueId = "the infinite queue" englishResultLocalisation EnqueueStrategyId = "the enqueueing strategy"

@@ -11,8 +11,11 @@ module Simulation.Aivika.Trans.Server        (-- * Server         Server,+        ServerInterruption(..),         newServer,         newStateServer,+        newInterruptibleServer,+        newInterruptibleStateServer,         -- * Processing         serverProcessor,         -- * Server Properties and Activities@@ -52,6 +55,7 @@         serverOutputWaitFactorChanged_,         -- * Basic Signals         serverInputReceived,+        serverTaskInterrupted,         serverTaskProcessed,         serverOutputProvided,         -- * Overall Signal@@ -59,6 +63,7 @@  import Data.Monoid +import Control.Monad import Control.Arrow  import Simulation.Aivika.Trans.Session@@ -77,6 +82,8 @@ import Simulation.Aivika.Trans.Stream import Simulation.Aivika.Trans.Statistics +import Simulation.Aivika.Server (ServerInterruption(..))+ -- | It models a server that takes @a@ and provides @b@ having state @s@ within underlying computation @m@. data Server m s a b =   Server { serverInitState :: s,@@ -85,6 +92,8 @@            -- ^ The current state of the server.            serverProcess :: s -> a -> Process m (s, b),            -- ^ Provide @b@ by specified @a@.+           serverProcessInterruptible :: Bool,+           -- ^ Whether the process is interruptible.            serverTotalInputWaitTimeRef :: ProtoRef m Double,            -- ^ The counted total time spent in awating the input.            serverTotalProcessingTimeRef :: ProtoRef m Double,@@ -99,6 +108,8 @@            -- ^ The statistics for the time spent for delivering the output.            serverInputReceivedSource :: SignalSource m a,            -- ^ A signal raised when the server recieves a new input to process.+           serverTaskInterruptedSource :: SignalSource m (ServerInterruption a),+           -- ^ A signal raised when the task was interrupted.            serverTaskProcessedSource :: SignalSource m (a, b),            -- ^ A signal raised when the input is processed and            -- the output is prepared for deliverying.@@ -107,17 +118,22 @@          }  -- | Create a new server that can provide output @b@ by input @a@.+--+-- By default, it is assumed that the server cannot be interrupted,+-- because the handling of possible task interruption is rather costly+-- operation. newServer :: MonadComp m              => (a -> Process m b)              -- ^ provide an output by the specified input              -> Simulation m (Server m () a b)-newServer provide =-  flip newStateServer () $ \s a ->-  do b <- provide a-     return (s, b)+newServer = newInterruptibleServer False  -- | Create a new server that can provide output @b@ by input @a@ -- starting from state @s@.+--+-- By default, it is assumed that the server cannot be interrupted,+-- because the handling of possible task interruption is rather costly+-- operation. newStateServer :: MonadComp m                   => (s -> a -> Process m (s, b))                   -- ^ provide a new state and output by the specified @@ -125,7 +141,32 @@                   -> s                   -- ^ the initial state                   -> Simulation m (Server m s a b)-newStateServer provide state =+newStateServer = newInterruptibleStateServer False++-- | Create a new interruptible server that can provide output @b@ by input @a@.+newInterruptibleServer :: MonadComp m+                          => Bool+                          -- ^ whether the server can be interrupted+                          -> (a -> Process m b)+                          -- ^ provide an output by the specified input+                          -> Simulation m (Server m () a b)+newInterruptibleServer interruptible provide =+  flip (newInterruptibleStateServer interruptible) () $ \s a ->+  do b <- provide a+     return (s, b)++-- | Create a new interruptible server that can provide output @b@ by input @a@+-- starting from state @s@.+newInterruptibleStateServer :: MonadComp m+                               => Bool+                               -- ^ whether the server can be interrupted+                               -> (s -> a -> Process m (s, b))+                               -- ^ provide a new state and output by the specified +                               -- old state and input+                               -> s+                               -- ^ the initial state+                               -> Simulation m (Server m s a b)+newInterruptibleStateServer interruptible provide state =   do sn <- liftParameter simulationSession      r0 <- liftComp $ newProtoRef sn state      r1 <- liftComp $ newProtoRef sn 0@@ -137,9 +178,11 @@      s1 <- newSignalSource      s2 <- newSignalSource      s3 <- newSignalSource+     s4 <- newSignalSource      let server = Server { serverInitState = state,                            serverStateRef = r0,                            serverProcess = provide,+                           serverProcessInterruptible = interruptible,                            serverTotalInputWaitTimeRef = r1,                            serverTotalProcessingTimeRef = r2,                            serverTotalOutputWaitTimeRef = r3,@@ -147,8 +190,9 @@                            serverProcessingTimeRef = r5,                            serverOutputWaitTimeRef = r6,                            serverInputReceivedSource = s1,-                           serverTaskProcessedSource = s2,-                           serverOutputProvidedSource = s3 }+                           serverTaskInterruptedSource = s2,+                           serverTaskProcessedSource = s3,+                           serverOutputProvidedSource = s4 }      return server  -- | Return a processor for the specified server.@@ -198,7 +242,10 @@                      addSamplingStats (t1 - t0)               triggerSignal (serverInputReceivedSource server) a          -- provide the service-         (s', b) <- serverProcess server s a+         (s', b) <-+           if serverProcessInterruptible server+           then serverProcessInterrupting server s a+           else serverProcess server s a          t2 <- liftDynamics time          liftEvent $            do liftComp $@@ -209,6 +256,24 @@               triggerSignal (serverTaskProcessedSource server) (a, b)          return (b, loop s' (Just (t2, a, b)) xs') +-- | Process the input with ability to handle a possible interruption.+serverProcessInterrupting :: MonadComp m => Server m s a b -> s -> a -> Process m (s, b)+serverProcessInterrupting server s a =+  do pid <- processId+     t1  <- liftDynamics time+     finallyProcess+       (serverProcess server s a)+       (liftEvent $+        do cancelled <- processCancelled pid+           when cancelled $+             do t2 <- liftDynamics time+                liftComp $+                  do modifyProtoRef' (serverTotalProcessingTimeRef server) (+ (t2 - t1))+                     modifyProtoRef' (serverProcessingTimeRef server) $+                       addSamplingStats (t2 - t1)+                let x = ServerInterruption a t1 t2+                triggerSignal (serverTaskInterruptedSource server) x)+ -- | Return the current state of the server. -- -- See also 'serverStateChanged' and 'serverStateChanged_'.@@ -451,6 +516,10 @@ serverInputReceived :: MonadComp m => Server m s a b -> Signal m a serverInputReceived = publishSignal . serverInputReceivedSource +-- | Raised when the task processing by the server was interrupted.+serverTaskInterrupted :: MonadComp m => Server m s a b -> Signal m (ServerInterruption a)+serverTaskInterrupted = publishSignal . serverTaskInterruptedSource+ -- | Raised when the server has just processed the task. serverTaskProcessed :: MonadComp m => Server m s a b -> Signal m (a, b) serverTaskProcessed = publishSignal . serverTaskProcessedSource@@ -463,6 +532,7 @@ serverChanged_ :: MonadComp m => Server m s a b -> Signal m () serverChanged_ server =   mapSignal (const ()) (serverInputReceived server) <>+  mapSignal (const ()) (serverTaskInterrupted server) <>   mapSignal (const ()) (serverTaskProcessed server) <>   mapSignal (const ()) (serverOutputProvided server) 

@@ -48,6 +48,8 @@         Signalable(..),         signalableChanged,         emptySignalable,-        appendSignalable) where+        appendSignalable,+        -- * Debugging+        traceSignal) where  import Simulation.Aivika.Trans.Internal.Signal

@@ -20,7 +20,10 @@         finallySimulation,         throwSimulation,         -- * Memoization-        memoSimulation) where+        memoSimulation,+        -- * Exceptions+        SimulationException(..),+        SimulationAbort(..)) where  import Simulation.Aivika.Trans.Internal.Specs import Simulation.Aivika.Trans.Internal.Simulation

@@ -27,6 +27,20 @@         timingStatsDeviation,         timingStatsSummary,         returnTimingStats,-        fromIntTimingStats) where+        fromIntTimingStats,+        -- * Simple Counter+        SamplingCounter(..),+        emptySamplingCounter,+        incSamplingCounter,+        decSamplingCounter,+        resetSamplingCounter,+        returnSamplingCounter,+        -- * Timing Counter+        TimingCounter(..),+        emptyTimingCounter,+        incTimingCounter,+        decTimingCounter,+        resetTimingCounter,+        returnTimingCounter) where  import Simulation.Aivika.Statistics

@@ -60,7 +60,9 @@         rightStream,         replaceLeftStream,         replaceRightStream,-        partitionEitherStream) where+        partitionEitherStream,+        -- * Debugging+        traceStream) where  import Data.Maybe import Data.Monoid@@ -548,3 +550,25 @@ -- | Delay the stream by one step using the specified initial value. delayStream :: MonadComp m => a -> Stream m a -> Stream m a delayStream a0 s = Cons $ return (a0, s)++-- | Show the debug messages with the current simulation time.+traceStream :: MonadComp m+               => Maybe String+               -- ^ the request message+               -> Maybe String+               -- ^ the response message+               -> Stream m a+               -- ^ a stream+               -> Stream m a+traceStream request response s = Cons $ loop s where+  loop s = do (a, xs) <-+                case request of+                  Nothing -> runStream s+                  Just message ->+                    traceProcess message $+                    runStream s+              case response of+                Nothing -> return (a, Cons $ loop xs)+                Just message ->+                  traceProcess message $+                  return (a, Cons $ loop xs)

@@ -1,5 +1,5 @@ name:            aivika-transformers-version:         2.1+version:         3.0 synopsis:        Transformers for the Aivika simulation library description:     The package adds the monad and other computation transformers to @@ -114,7 +114,7 @@                      array >= 0.3.0.0,                      containers >= 0.4.0.0,                      random >= 1.0.0.3,-                     aivika >= 2.0+                     aivika >= 3.0      if !flag(haste-inst)        build-depends:   vector >= 0.10.0.1@@ -130,6 +130,7 @@                         ExistentialQuantification,                         TypeFamilies,                         TypeSynonymInstances,+                        DeriveDataTypeable,                         CPP                           ghc-options:     -O2