\subsection{Cardano.BM.Tracer}
\label{code:Cardano.BM.Tracer}

%if style == newcode
\begin{code}
{-# LANGUAGE InstanceSigs         #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{-@ LIQUID "--prune-unsorted" @-}

module Cardano.BM.Tracer
    (
      Tracer (..)
    -- * observing
    , bracketObserve
    -- * examples
    , example
    , exampleWithChoose
    ) where

import           Data.Functor.Contravariant (contramap)
import           Data.Functor.Contravariant.Divisible (Divisible (..),
                     Decidable (..))
import           Data.Void (Void)
import           Data.Word (Word64)
import           GHC.Clock (getMonotonicTimeNSec)

import           Control.Tracer (Tracer (..), nullTracer, showTracing,
                                     stdoutTracer, traceWith)
import           Control.Tracer.Observe (Observable (..), ObserveIndicator (..))

\end{code}
%endif

\subsubsection{Divisible and Decidable instances of |Tracer|}
A |Divisible| contravariant functor is the contravariant analogue of
|Applicative|. A |Divisible| contravariant functor has the ability to
be composed "beside" another contravariant. It gives a way to combine
two contravariant functors that focus on different parts of a
structure.
(see \url{https://hackage.haskell.org/package/contravariant-1.5/docs/Data-Functor-Contravariant-Divisible.html#g:1})

\begin{code}
instance Applicative m => Divisible (Tracer m) where
  divide  :: (a -> (b, c)) -> Tracer m b -> Tracer m c -> Tracer m a
  divide :: (a -> (b, c)) -> Tracer m b -> Tracer m c -> Tracer m a
divide a -> (b, c)
f (Tracer b -> m ()
g) (Tracer c -> m ()
h) = (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 -> case a -> (b, c)
f a
a of
    (b
b, c
c) -> b -> m ()
g b
b m () -> m () -> m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> c -> m ()
h c
c

  conquer :: Tracer m a
  conquer :: Tracer m a
conquer = Tracer m a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer

\end{code}
A |Decidable| contravariant functor is the contravariant analogue of
|Alternative|. Noting the superclass constraint that the
contravariant functor must also be |Divisible|, a |Decidable| functor
has the ability to "fan out" input, under the intuition that
contravariant functors consume input. It chooses the appropriate
contravariant functor for a data structure that is an alternative
choice (sum) of two different parts.
(see \url{https://hackage.haskell.org/package/contravariant-1.5/docs/Data-Functor-Contravariant-Divisible.html#g:2})

\begin{code}
instance Applicative m => Decidable (Tracer m) where
  lose :: (a -> Void) -> Tracer m a
  lose :: (a -> Void) -> Tracer m a
lose a -> Void
_ = Tracer m a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer

  choose :: (a -> Either b c) -> Tracer m b -> Tracer m c -> Tracer m a
  choose :: (a -> Either b c) -> Tracer m b -> Tracer m c -> Tracer m a
choose a -> Either b c
f (Tracer b -> m ()
g) (Tracer c -> m ()
h) = (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
$ (b -> m ()) -> (c -> m ()) -> Either b c -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either b -> m ()
g c -> m ()
h (Either b c -> m ()) -> (a -> Either b c) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either b c
f

\end{code}

\subsubsection{bracketObserve}\label{code:bracketObserve}\index{bracketObserve}
Indicates the beginning and the end of an action.
|matchObservations| can be used if we want a |Tracer| which
produces the difference between the starting and the ending
observations of the action.
\begin{code}
bracketObserve :: forall m s e b d . Monad m
               => (m s, m e, Tracer m (Observable s e d))
               -> m b
               -> m b
bracketObserve :: (m s, m e, Tracer m (Observable s e d)) -> m b -> m b
bracketObserve (m s
getStart, m e
getEnd, Tracer m (Observable s e d)
tr) m b
action = do

    let transform :: Tracer m (Observable s e d) -> Tracer m ObserveIndicator
        transform :: Tracer m (Observable s e d) -> Tracer m ObserveIndicator
transform Tracer m (Observable s e d)
trace =  (ObserveIndicator -> m ()) -> Tracer m ObserveIndicator
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((ObserveIndicator -> m ()) -> Tracer m ObserveIndicator)
-> (ObserveIndicator -> m ()) -> Tracer m ObserveIndicator
forall a b. (a -> b) -> a -> b
$ \case
            ObserveIndicator
ObserveBefore -> do
                s
start <- m s
getStart
                Tracer m (Observable s e d) -> Observable s e d -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Observable s e d)
trace (Observable s e d -> m ()) -> Observable s e d -> m ()
forall a b. (a -> b) -> a -> b
$ s -> Observable s e d
forall s e d. s -> Observable s e d
OStart s
start
            ObserveIndicator
ObserveAfter -> do
                e
end <- m e
getEnd
                Tracer m (Observable s e d) -> Observable s e d -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (Observable s e d)
trace (Observable s e d -> m ()) -> Observable s e d -> m ()
forall a b. (a -> b) -> a -> b
$ e -> Maybe d -> Observable s e d
forall s e d. e -> Maybe d -> Observable s e d
OEnd e
end Maybe d
forall a. Maybe a
Nothing

        tr' :: Tracer m ObserveIndicator
tr' = Tracer m (Observable s e d) -> Tracer m ObserveIndicator
transform Tracer m (Observable s e d)
tr

    Tracer m ObserveIndicator -> ObserveIndicator -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m ObserveIndicator
tr' ObserveIndicator
ObserveBefore
    b
res <- m b
action
    Tracer m ObserveIndicator -> ObserveIndicator -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m ObserveIndicator
tr' ObserveIndicator
ObserveAfter

    b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res

\end{code}

\subsubsection{example}
\begin{code}
data AddSub a = Add a
              | Sub a
              deriving Int -> AddSub a -> ShowS
[AddSub a] -> ShowS
AddSub a -> String
(Int -> AddSub a -> ShowS)
-> (AddSub a -> String) -> ([AddSub a] -> ShowS) -> Show (AddSub a)
forall a. Show a => Int -> AddSub a -> ShowS
forall a. Show a => [AddSub a] -> ShowS
forall a. Show a => AddSub a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AddSub a] -> ShowS
$cshowList :: forall a. Show a => [AddSub a] -> ShowS
show :: AddSub a -> String
$cshow :: forall a. Show a => AddSub a -> String
showsPrec :: Int -> AddSub a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AddSub a -> ShowS
Show

type Time = Word64

type ObservableS t = Observable t t t

example :: IO Int
example :: IO Int
example = do
    let trInt :: Tracer IO (AddSub Int)
        trInt :: Tracer IO (AddSub Int)
trInt = Tracer IO String -> Tracer IO (AddSub Int)
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer IO String
forall (m :: * -> *). MonadIO m => Tracer m String
stdoutTracer
        trObserve :: Tracer IO (ObservableS Time)
        trObserve :: Tracer IO (ObservableS Time)
trObserve = Tracer IO String -> Tracer IO (ObservableS Time)
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer IO String
forall (m :: * -> *). MonadIO m => Tracer m String
stdoutTracer

    Int
_ <- (IO Time, IO Time, Tracer IO (ObservableS Time))
-> IO Int -> IO Int
forall (m :: * -> *) s e b d.
Monad m =>
(m s, m e, Tracer m (Observable s e d)) -> m b -> m b
bracketObserve (IO Time
getMonotonicTimeNSec, IO Time
getMonotonicTimeNSec, Tracer IO (ObservableS Time)
trObserve) (Tracer IO (AddSub Int) -> IO Int
actionAdd Tracer IO (AddSub Int)
trInt)
    (IO Time, IO Time, Tracer IO (ObservableS Time))
-> IO Int -> IO Int
forall (m :: * -> *) s e b d.
Monad m =>
(m s, m e, Tracer m (Observable s e d)) -> m b -> m b
bracketObserve (IO Time
getMonotonicTimeNSec, IO Time
getMonotonicTimeNSec, Tracer IO (ObservableS Time)
trObserve) (Tracer IO (AddSub Int) -> IO Int
actionSub Tracer IO (AddSub Int)
trInt)

  where
    actionAdd :: Tracer IO (AddSub Int) -> IO Int
    actionAdd :: Tracer IO (AddSub Int) -> IO Int
actionAdd Tracer IO (AddSub Int)
tr = do
        let res :: Int
res = Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2
        Tracer IO (AddSub Int) -> AddSub Int -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (AddSub Int)
tr (AddSub Int -> IO ()) -> AddSub Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> AddSub Int
forall a. a -> AddSub a
Add Int
res
        Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
res
    actionSub :: Tracer IO (AddSub Int) -> IO Int
    actionSub :: Tracer IO (AddSub Int) -> IO Int
actionSub Tracer IO (AddSub Int)
tr = do
        let res :: Int
res = Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2
        Tracer IO (AddSub Int) -> AddSub Int -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (AddSub Int)
tr (AddSub Int -> IO ()) -> AddSub Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> AddSub Int
forall a. a -> AddSub a
Sub Int
res
        Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
res

exampleWithChoose :: IO Int
exampleWithChoose :: IO Int
exampleWithChoose = do
    let trInt :: Tracer IO (AddSub Int)
        trInt :: Tracer IO (AddSub Int)
trInt = Tracer IO String -> Tracer IO (AddSub Int)
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer IO String
forall (m :: * -> *). MonadIO m => Tracer m String
stdoutTracer
        trObserve :: Tracer IO (ObservableS (AddSub Time))
        trObserve :: Tracer IO (ObservableS (AddSub Time))
trObserve = Tracer IO String -> Tracer IO (ObservableS (AddSub Time))
forall a (m :: * -> *). Show a => Tracer m String -> Tracer m a
showTracing Tracer IO String
forall (m :: * -> *). MonadIO m => Tracer m String
stdoutTracer

        trace :: Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
        trace :: Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
trace = (Either (ObservableS (AddSub Time)) (AddSub Int)
 -> Either (ObservableS (AddSub Time)) (AddSub Int))
-> Tracer IO (ObservableS (AddSub Time))
-> Tracer IO (AddSub Int)
-> Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
forall (f :: * -> *) a b c.
Decidable f =>
(a -> Either b c) -> f b -> f c -> f a
choose Either (ObservableS (AddSub Time)) (AddSub Int)
-> Either (ObservableS (AddSub Time)) (AddSub Int)
forall a. a -> a
id Tracer IO (ObservableS (AddSub Time))
trObserve Tracer IO (AddSub Int)
trInt

        bracketObserve' :: (m e, Tracer m (Observable e e d)) -> m b -> m b
bracketObserve' (m e
getTime, Tracer m (Observable e e d)
tr) = (m e, m e, Tracer m (Observable e e d)) -> m b -> m b
forall (m :: * -> *) s e b d.
Monad m =>
(m s, m e, Tracer m (Observable s e d)) -> m b -> m b
bracketObserve (m e
getTime, m e
getTime, Tracer m (Observable e e d)
tr)

    Int
_ <- (IO (AddSub Time), Tracer IO (ObservableS (AddSub Time)))
-> IO Int -> IO Int
forall (m :: * -> *) e d b.
Monad m =>
(m e, Tracer m (Observable e e d)) -> m b -> m b
bracketObserve' (Time -> AddSub Time
forall a. a -> AddSub a
Add (Time -> AddSub Time) -> IO Time -> IO (AddSub Time)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Time
getMonotonicTimeNSec, (ObservableS (AddSub Time)
 -> Either (ObservableS (AddSub Time)) (AddSub Int))
-> Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
-> Tracer IO (ObservableS (AddSub Time))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ObservableS (AddSub Time)
-> Either (ObservableS (AddSub Time)) (AddSub Int)
forall a b. a -> Either a b
Left Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
trace) (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Tracer IO (AddSub Int) -> IO Int
actionAdd (Tracer IO (AddSub Int) -> IO Int)
-> Tracer IO (AddSub Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ (AddSub Int -> Either (ObservableS (AddSub Time)) (AddSub Int))
-> Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
-> Tracer IO (AddSub Int)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap AddSub Int -> Either (ObservableS (AddSub Time)) (AddSub Int)
forall a b. b -> Either a b
Right Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
trace
    (IO (AddSub Time), Tracer IO (ObservableS (AddSub Time)))
-> IO Int -> IO Int
forall (m :: * -> *) e d b.
Monad m =>
(m e, Tracer m (Observable e e d)) -> m b -> m b
bracketObserve' (Time -> AddSub Time
forall a. a -> AddSub a
Sub (Time -> AddSub Time) -> IO Time -> IO (AddSub Time)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Time
getMonotonicTimeNSec, (ObservableS (AddSub Time)
 -> Either (ObservableS (AddSub Time)) (AddSub Int))
-> Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
-> Tracer IO (ObservableS (AddSub Time))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap ObservableS (AddSub Time)
-> Either (ObservableS (AddSub Time)) (AddSub Int)
forall a b. a -> Either a b
Left Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
trace) (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Tracer IO (AddSub Int) -> IO Int
actionSub (Tracer IO (AddSub Int) -> IO Int)
-> Tracer IO (AddSub Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ (AddSub Int -> Either (ObservableS (AddSub Time)) (AddSub Int))
-> Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
-> Tracer IO (AddSub Int)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap AddSub Int -> Either (ObservableS (AddSub Time)) (AddSub Int)
forall a b. b -> Either a b
Right Tracer IO (Either (ObservableS (AddSub Time)) (AddSub Int))
trace

  where
    actionAdd :: Tracer IO (AddSub Int) -> IO Int
    actionAdd :: Tracer IO (AddSub Int) -> IO Int
actionAdd Tracer IO (AddSub Int)
tr = do
        let res :: Int
res = Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2
        Tracer IO (AddSub Int) -> AddSub Int -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (AddSub Int)
tr (AddSub Int -> IO ()) -> AddSub Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> AddSub Int
forall a. a -> AddSub a
Add Int
res
        Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
res
    actionSub :: Tracer IO (AddSub Int) -> IO Int
    actionSub :: Tracer IO (AddSub Int) -> IO Int
actionSub Tracer IO (AddSub Int)
tr = do
        let res :: Int
res = Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2
        Tracer IO (AddSub Int) -> AddSub Int -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO (AddSub Int)
tr (AddSub Int -> IO ()) -> AddSub Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> AddSub Int
forall a. a -> AddSub a
Sub Int
res
        Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
res

instance Show (ObservableS Time) where
  show :: ObservableS Time -> String
show (OStart Time
time)     = String
"OStart " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Time -> String
forall a. Show a => a -> String
show Time
time
  show (OEnd Time
time Maybe Time
mTime) = String
"OEnd "   String -> ShowS
forall a. [a] -> [a] -> [a]
++ Time -> String
forall a. Show a => a -> String
show Time
time String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", ODiff " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Time -> String
forall a. Show a => a -> String
show Maybe Time
mTime

instance Show (ObservableS (AddSub Time)) where
  show :: ObservableS (AddSub Time) -> String
show (OStart AddSub Time
a)   = String
"OStart " String -> ShowS
forall a. [a] -> [a] -> [a]
++ AddSub Time -> String
forall a. Show a => a -> String
show AddSub Time
a
  show (OEnd   AddSub Time
a Maybe (AddSub Time)
b) = String
"OEnd "   String -> ShowS
forall a. [a] -> [a] -> [a]
++ AddSub Time -> String
forall a. Show a => a -> String
show AddSub Time
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", ODiff "  String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe (AddSub Time) -> String
forall a. Show a => a -> String
show Maybe (AddSub Time)
b

\end{code}