\label{code:Control.Tracer.Transformers.ObserveOutcome}

%if style == newcode
\begin{code}
{-|
Module: ObserveOutcome

Observing events with annotations of thread id and time.
-}
{-# LANGUAGE BangPatterns           #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}

module Control.Tracer.Transformers.ObserveOutcome
    (
    -- * transformer
      Outcome (..)
    , OutcomeEnhancedTracer
    , OutcomeFidelity (..)
    , OutcomeProgressionStatus (..)
    , mkOutcomeExtractor
    ) where


import           Control.Monad.IO.Class (MonadIO (..))

import           Control.Concurrent.MVar (MVar, newMVar, takeMVar, putMVar)

import           Control.Exception.Safe (MonadMask)
import qualified Control.Exception.Safe as CES

import           Control.Tracer (Tracer (..), traceWith)

\end{code}
%endif

\begin{code}
-- transformer of traces that have the structure of an 'Outcome'
-- (beginning and possible end)

-- the distinct stages
data OutcomeProgressionStatus
  = OutcomeStarts
  | OutcomeOther
  | OutcomeEnds
  deriving (OutcomeProgressionStatus -> OutcomeProgressionStatus -> Bool
(OutcomeProgressionStatus -> OutcomeProgressionStatus -> Bool)
-> (OutcomeProgressionStatus -> OutcomeProgressionStatus -> Bool)
-> Eq OutcomeProgressionStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OutcomeProgressionStatus -> OutcomeProgressionStatus -> Bool
$c/= :: OutcomeProgressionStatus -> OutcomeProgressionStatus -> Bool
== :: OutcomeProgressionStatus -> OutcomeProgressionStatus -> Bool
$c== :: OutcomeProgressionStatus -> OutcomeProgressionStatus -> Bool
Eq)

-- constructing an outcome from a sequence of observables
class (Monad m) => Outcome m a where
  type IntermediateValue a
  type OutcomeMetric a

  classifyObservable     :: a
                         -> m OutcomeProgressionStatus
  captureObservableValue :: a
                         -> m (IntermediateValue a)
  computeOutcomeMetric   :: a
                         -> IntermediateValue a
                         -> IntermediateValue a
                         -> m (OutcomeMetric a)

-- | The Maybe (OutcomeMetric a) captures the 'DeltaQ-ness' of the
--   nature of outcomes, may / may not complete.
type OutcomeEnhancedTracer m a
  = Tracer m (Either a (OutcomeFidelity (OutcomeMetric a)))

-- | Also need to know that observables happened in the "right way"

data OutcomeFidelity a
  = EndsBeforeStarted
  | StartsBeforeEnds a
  | ProgressedNormally a
--  might have "timeout" and/or Failureprogression?
  deriving (Int -> OutcomeFidelity a -> ShowS
[OutcomeFidelity a] -> ShowS
OutcomeFidelity a -> String
(Int -> OutcomeFidelity a -> ShowS)
-> (OutcomeFidelity a -> String)
-> ([OutcomeFidelity a] -> ShowS)
-> Show (OutcomeFidelity a)
forall a. Show a => Int -> OutcomeFidelity a -> ShowS
forall a. Show a => [OutcomeFidelity a] -> ShowS
forall a. Show a => OutcomeFidelity a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [OutcomeFidelity a] -> ShowS
$cshowList :: forall a. Show a => [OutcomeFidelity a] -> ShowS
show :: OutcomeFidelity a -> String
$cshow :: forall a. Show a => OutcomeFidelity a -> String
showsPrec :: Int -> OutcomeFidelity a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> OutcomeFidelity a -> ShowS
Show)

-- | Custom function for @MVar@, relying on two pretty standard
-- constraints.
liftedModifyMVar_ :: (MonadIO m, MonadMask m) => MVar a -> (a -> m a) -> m ()
liftedModifyMVar_ :: MVar a -> (a -> m a) -> m ()
liftedModifyMVar_ MVar a
m a -> m a
io =
  ((forall a. m a -> m a) -> m ()) -> m ()
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
CES.mask (((forall a. m a -> m a) -> m ()) -> m ())
-> ((forall a. m a -> m a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> do
    a
a  <- IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ MVar a -> IO a
forall a. MVar a -> IO a
takeMVar MVar a
m
    a
a' <- m a -> m a
forall a. m a -> m a
restore (a -> m a
io a
a) m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`CES.onException` (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
a)
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar a -> a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar a
m a
a'

-- | Generic Trace transformer. It could be written to take
--   an initial argument, but restricting the scope of that
--   per-invocation state seems more appropriate (for the
--   moment). That may be of use if\/when explict management of
--   timeout was required and\/or non-termination of the outcome at
--   the end of a run was of interest.
mkOutcomeExtractor
    :: forall m a. (MonadIO m, MonadMask m, Outcome m a)
    => m (OutcomeEnhancedTracer m a -> Tracer m a)
mkOutcomeExtractor :: m (OutcomeEnhancedTracer m a -> Tracer m a)
mkOutcomeExtractor = do
    -- We always instantiate a new MVar for the outcome.
    MVar (Maybe (IntermediateValue a))
maybeInterValue <- IO (MVar (Maybe (IntermediateValue a)))
-> m (MVar (Maybe (IntermediateValue a)))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (Maybe (IntermediateValue a)))
 -> m (MVar (Maybe (IntermediateValue a))))
-> IO (MVar (Maybe (IntermediateValue a)))
-> m (MVar (Maybe (IntermediateValue a)))
forall a b. (a -> b) -> a -> b
$ Maybe (IntermediateValue a)
-> IO (MVar (Maybe (IntermediateValue a)))
forall a. a -> IO (MVar a)
newMVar Maybe (IntermediateValue a)
forall a. Maybe a
Nothing
    (OutcomeEnhancedTracer m a -> Tracer m a)
-> m (OutcomeEnhancedTracer m a -> Tracer m a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((OutcomeEnhancedTracer m a -> Tracer m a)
 -> m (OutcomeEnhancedTracer m a -> Tracer m a))
-> (OutcomeEnhancedTracer m a -> Tracer m a)
-> m (OutcomeEnhancedTracer m a -> Tracer m a)
forall a b. (a -> b) -> a -> b
$ MVar (Maybe (IntermediateValue a))
-> OutcomeEnhancedTracer m a -> Tracer m a
traceOutcomes MVar (Maybe (IntermediateValue a))
maybeInterValue
  where
    traceOutcomes
        :: MVar (Maybe (IntermediateValue a))
        -> OutcomeEnhancedTracer m a
        -> Tracer m a
    traceOutcomes :: MVar (Maybe (IntermediateValue a))
-> OutcomeEnhancedTracer m a -> Tracer m a
traceOutcomes MVar (Maybe (IntermediateValue a))
maybeInterValue OutcomeEnhancedTracer m a
tr = (a -> m ()) -> Tracer m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> m ()) -> Tracer m a) -> (a -> m ()) -> Tracer m a
forall a b. (a -> b) -> a -> b
$ \a
a -> do
      OutcomeProgressionStatus
classifedObservable <- a -> m OutcomeProgressionStatus
forall (m :: * -> *) a.
Outcome m a =>
a -> m OutcomeProgressionStatus
classifyObservable a
a
      case OutcomeProgressionStatus
classifedObservable of
        OutcomeProgressionStatus
OutcomeOther    -> OutcomeEnhancedTracer m a
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith OutcomeEnhancedTracer m a
tr (Either a (OutcomeFidelity (OutcomeMetric a)) -> m ())
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall a b. (a -> b) -> a -> b
$ a -> Either a (OutcomeFidelity (OutcomeMetric a))
forall a b. a -> Either a b
Left a
a
        OutcomeProgressionStatus
outcome         -> MVar (Maybe (IntermediateValue a))
-> (Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a)))
-> m ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
MVar a -> (a -> m a) -> m ()
liftedModifyMVar_ MVar (Maybe (IntermediateValue a))
maybeInterValue ((Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a)))
 -> m ())
-> (Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a)))
-> m ()
forall a b. (a -> b) -> a -> b
$ \Maybe (IntermediateValue a)
observedResult -> case Maybe (IntermediateValue a)
observedResult of
                Maybe (IntermediateValue a)
Nothing   -> OutcomeProgressionStatus -> a -> m (Maybe (IntermediateValue a))
outcomeWithoutValue OutcomeProgressionStatus
outcome a
a
                (Just IntermediateValue a
b)  -> OutcomeProgressionStatus
-> a -> IntermediateValue a -> m (Maybe (IntermediateValue a))
outcomeWithValue OutcomeProgressionStatus
outcome a
a IntermediateValue a
b
      () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
       where
        -- If we don't have any intermediate values and the outcome is
        -- @OutcomeStarts@, then we set the initial value inside the MVar.
        outcomeWithoutValue :: OutcomeProgressionStatus -> a -> m (Maybe (IntermediateValue a))
        outcomeWithoutValue :: OutcomeProgressionStatus -> a -> m (Maybe (IntermediateValue a))
outcomeWithoutValue OutcomeProgressionStatus
OutcomeStarts a
a = do
            !IntermediateValue a
z <- a -> m (IntermediateValue a)
forall (m :: * -> *) a. Outcome m a => a -> m (IntermediateValue a)
captureObservableValue a
a
            OutcomeEnhancedTracer m a
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith OutcomeEnhancedTracer m a
tr (Either a (OutcomeFidelity (OutcomeMetric a)) -> m ())
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall a b. (a -> b) -> a -> b
$ a -> Either a (OutcomeFidelity (OutcomeMetric a))
forall a b. a -> Either a b
Left a
a
            Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a)))
-> Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a))
forall a b. (a -> b) -> a -> b
$ IntermediateValue a -> Maybe (IntermediateValue a)
forall a. a -> Maybe a
Just IntermediateValue a
z
        outcomeWithoutValue OutcomeProgressionStatus
_otherwise a
a = do -- Outcome ends
            OutcomeEnhancedTracer m a
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith OutcomeEnhancedTracer m a
tr (Either a (OutcomeFidelity (OutcomeMetric a)) -> m ())
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall a b. (a -> b) -> a -> b
$ a -> Either a (OutcomeFidelity (OutcomeMetric a))
forall a b. a -> Either a b
Left a
a
            OutcomeEnhancedTracer m a
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith OutcomeEnhancedTracer m a
tr (Either a (OutcomeFidelity (OutcomeMetric a)) -> m ())
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall a b. (a -> b) -> a -> b
$ OutcomeFidelity (OutcomeMetric a)
-> Either a (OutcomeFidelity (OutcomeMetric a))
forall a b. b -> Either a b
Right OutcomeFidelity (OutcomeMetric a)
forall a. OutcomeFidelity a
EndsBeforeStarted
            -- We remove what we had been measuring, this should
            -- probably be an error as well.
            Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a)))
-> Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a))
forall a b. (a -> b) -> a -> b
$ Maybe (IntermediateValue a)
forall a. Maybe a
Nothing

        -- If we do have any intermediate values and the outcome is
        -- @OutcomeStarts@, then we set the initial value inside the MVar.
        outcomeWithValue :: OutcomeProgressionStatus -> a -> IntermediateValue a -> m (Maybe (IntermediateValue a))
        outcomeWithValue :: OutcomeProgressionStatus
-> a -> IntermediateValue a -> m (Maybe (IntermediateValue a))
outcomeWithValue OutcomeProgressionStatus
OutcomeEnds a
a IntermediateValue a
b = do
            !IntermediateValue a
z <- a -> m (IntermediateValue a)
forall (m :: * -> *) a. Outcome m a => a -> m (IntermediateValue a)
captureObservableValue a
a
            OutcomeEnhancedTracer m a
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith OutcomeEnhancedTracer m a
tr (Either a (OutcomeFidelity (OutcomeMetric a)) -> m ())
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall a b. (a -> b) -> a -> b
$ a -> Either a (OutcomeFidelity (OutcomeMetric a))
forall a b. a -> Either a b
Left a
a
            OutcomeMetric a
v <- a
-> IntermediateValue a
-> IntermediateValue a
-> m (OutcomeMetric a)
forall (m :: * -> *) a.
Outcome m a =>
a
-> IntermediateValue a
-> IntermediateValue a
-> m (OutcomeMetric a)
computeOutcomeMetric a
a IntermediateValue a
b IntermediateValue a
z
            OutcomeEnhancedTracer m a
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith OutcomeEnhancedTracer m a
tr (Either a (OutcomeFidelity (OutcomeMetric a)) -> m ())
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall a b. (a -> b) -> a -> b
$ OutcomeFidelity (OutcomeMetric a)
-> Either a (OutcomeFidelity (OutcomeMetric a))
forall a b. b -> Either a b
Right (OutcomeMetric a -> OutcomeFidelity (OutcomeMetric a)
forall a. a -> OutcomeFidelity a
ProgressedNormally OutcomeMetric a
v)
            Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a)))
-> Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a))
forall a b. (a -> b) -> a -> b
$ Maybe (IntermediateValue a)
forall a. Maybe a
Nothing
        outcomeWithValue OutcomeProgressionStatus
_otherwise a
a IntermediateValue a
b = do -- OutcomeStarts, this could be ignored since it "resets".
            !IntermediateValue a
z <- a -> m (IntermediateValue a)
forall (m :: * -> *) a. Outcome m a => a -> m (IntermediateValue a)
captureObservableValue a
a
            OutcomeEnhancedTracer m a
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith OutcomeEnhancedTracer m a
tr (Either a (OutcomeFidelity (OutcomeMetric a)) -> m ())
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall a b. (a -> b) -> a -> b
$ a -> Either a (OutcomeFidelity (OutcomeMetric a))
forall a b. a -> Either a b
Left a
a
            OutcomeMetric a
v <- a
-> IntermediateValue a
-> IntermediateValue a
-> m (OutcomeMetric a)
forall (m :: * -> *) a.
Outcome m a =>
a
-> IntermediateValue a
-> IntermediateValue a
-> m (OutcomeMetric a)
computeOutcomeMetric a
a IntermediateValue a
b IntermediateValue a
z
            OutcomeEnhancedTracer m a
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith OutcomeEnhancedTracer m a
tr (Either a (OutcomeFidelity (OutcomeMetric a)) -> m ())
-> Either a (OutcomeFidelity (OutcomeMetric a)) -> m ()
forall a b. (a -> b) -> a -> b
$ OutcomeFidelity (OutcomeMetric a)
-> Either a (OutcomeFidelity (OutcomeMetric a))
forall a b. b -> Either a b
Right (OutcomeMetric a -> OutcomeFidelity (OutcomeMetric a)
forall a. a -> OutcomeFidelity a
StartsBeforeEnds OutcomeMetric a
v) -- Probably some error.
            Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a)))
-> Maybe (IntermediateValue a) -> m (Maybe (IntermediateValue a))
forall a b. (a -> b) -> a -> b
$ IntermediateValue a -> Maybe (IntermediateValue a)
forall a. a -> Maybe a
Just IntermediateValue a
z

\end{code}