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

%if style == newcode
\begin{code}
{-# LANGUAGE RankNTypes #-}

module Cardano.BM.Trace
    (
      Trace
    , stdoutTrace
    , nullTracer
    , traceInTVar
    , traceInTVarIO
    -- * context naming
    , appendName
    , modifyName
    -- * utils
    , natTrace
    -- * log functions
    , traceNamedObject
    , traceNamedItem
    , logAlert,     logAlertS
    , logCritical,  logCriticalS
    , logDebug,     logDebugS
    , logEmergency, logEmergencyS
    , logError,     logErrorS
    , logInfo,      logInfoS
    , logNotice,    logNoticeS
    , logWarning,   logWarningS
    ) where

import           Control.Concurrent.MVar (MVar, newMVar, withMVar)
import qualified Control.Concurrent.STM.TVar as STM
import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Monad.STM as STM
import           Data.Aeson.Text (encodeToLazyText)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import           Data.Text.Lazy (toStrict)
import           System.IO.Unsafe (unsafePerformIO)

import           Cardano.BM.Data.LogItem
import           Cardano.BM.Data.Severity
import           Cardano.BM.Data.Trace (Trace)
import           Cardano.BM.Data.Tracer (Tracer (..), contramap, natTracer,
                     nullTracer, traceWith)

\end{code}
%endif

\subsubsection{Utilities}
Natural transformation from monad |m| to monad |n|.
\begin{code}
natTrace :: (forall x . m x -> n x) -> Tracer m (LoggerName,LogObject a) -> Tracer n (LoggerName,LogObject a)
natTrace :: (forall x. m x -> n x)
-> Tracer m (LoggerName, LogObject a)
-> Tracer n (LoggerName, LogObject a)
natTrace = (forall x. m x -> n x)
-> Tracer m (LoggerName, LogObject a)
-> Tracer n (LoggerName, LogObject a)
forall (m :: * -> *) (n :: * -> *) s.
(forall x. m x -> n x) -> Tracer m s -> Tracer n s
natTracer

\end{code}

\subsubsection{Enter new named context}\label{code:appendName}\index{appendName}
A new context name is added.
\begin{code}
appendName :: LoggerName -> Trace m a -> Trace m a
appendName :: LoggerName -> Trace m a -> Trace m a
appendName LoggerName
name Trace m a
tr = ((LoggerName, LogObject a) -> m ()) -> Trace m a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (((LoggerName, LogObject a) -> m ()) -> Trace m a)
-> ((LoggerName, LogObject a) -> m ()) -> Trace m a
forall a b. (a -> b) -> a -> b
$ \(LoggerName
names0, LogObject a
lo) ->
    let names :: LoggerName
names = if LoggerName
names0 LoggerName -> LoggerName -> Bool
forall a. Eq a => a -> a -> Bool
== LoggerName
T.empty then LoggerName
name else LoggerName
name LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
"." LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
names0
    in
    Trace m a -> (LoggerName, LogObject a) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Trace m a
tr (LoggerName
names, LogObject a
lo)

\end{code}

\subsubsection{Change named context}\label{code:modifyName}\index{modifyName}
The context name is overwritten.
\begin{code}
modifyName
    :: (LoggerName -> LoggerName)
    -> Trace m a
    -> Trace m a
modifyName :: (LoggerName -> LoggerName) -> Trace m a -> Trace m a
modifyName LoggerName -> LoggerName
k = ((LoggerName, LogObject a) -> (LoggerName, LogObject a))
-> Trace m a -> Trace m a
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (LoggerName, LogObject a) -> (LoggerName, LogObject a)
forall b. (LoggerName, b) -> (LoggerName, b)
f
  where
    f :: (LoggerName, b) -> (LoggerName, b)
f (LoggerName
names0, b
lo) = (LoggerName -> LoggerName
k LoggerName
names0, b
lo)

\end{code}

\subsubsection{Contramap a trace and produce the naming context}
\begin{code}
named :: Tracer m (LoggerName,LogObject a) -> Tracer m (LOMeta, LOContent a)
named :: Tracer m (LoggerName, LogObject a)
-> Tracer m (LOMeta, LOContent a)
named = ((LOMeta, LOContent a) -> (LoggerName, LogObject a))
-> Tracer m (LoggerName, LogObject a)
-> Tracer m (LOMeta, LOContent a)
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap (((LOMeta, LOContent a) -> (LoggerName, LogObject a))
 -> Tracer m (LoggerName, LogObject a)
 -> Tracer m (LOMeta, LOContent a))
-> ((LOMeta, LOContent a) -> (LoggerName, LogObject a))
-> Tracer m (LoggerName, LogObject a)
-> Tracer m (LOMeta, LOContent a)
forall a b. (a -> b) -> a -> b
$ \(LOMeta
meta, LOContent a
loc) -> (LoggerName
forall a. Monoid a => a
mempty, LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject LoggerName
forall a. Monoid a => a
mempty LOMeta
meta LOContent a
loc)

\end{code}

\subsubsection{Trace a |LogObject| through}
\label{code:traceNamedObject}\index{traceNamedObject}
\begin{code}
traceNamedObject
    :: MonadIO m
    => Trace m a
    -> (LOMeta, LOContent a)
    -> m ()
traceNamedObject :: Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace m a
logTrace (LOMeta, LOContent a)
lo =
    Tracer m (LOMeta, LOContent a) -> (LOMeta, LOContent a) -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith (Trace m a -> Tracer m (LOMeta, LOContent a)
forall (m :: * -> *) a.
Tracer m (LoggerName, LogObject a)
-> Tracer m (LOMeta, LOContent a)
named Trace m a
logTrace) (LOMeta, LOContent a)
lo

\end{code}

\subsubsection{Concrete Trace on stdout}\label{code:stdoutTrace}\index{stdoutTrace}

This function returns a trace with an action of type "|LogObject a -> IO ()|"
which will output a text message as text and all others as JSON encoded representation
to the console.

\todo[inline]{TODO remove |locallock|}
%if style == newcode
\begin{code}
{-# NOINLINE locallock #-}
\end{code}
%endif
\begin{code}
locallock :: MVar ()
locallock :: MVar ()
locallock = IO (MVar ()) -> MVar ()
forall a. IO a -> a
unsafePerformIO (IO (MVar ()) -> MVar ()) -> IO (MVar ()) -> MVar ()
forall a b. (a -> b) -> a -> b
$ () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
\end{code}

\begin{code}
stdoutTrace :: Trace IO T.Text
stdoutTrace :: Trace IO LoggerName
stdoutTrace = ((LoggerName, LogObject LoggerName) -> IO ())
-> Trace IO LoggerName
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer (((LoggerName, LogObject LoggerName) -> IO ())
 -> Trace IO LoggerName)
-> ((LoggerName, LogObject LoggerName) -> IO ())
-> Trace IO LoggerName
forall a b. (a -> b) -> a -> b
$ \(LoggerName
ctx, LogObject LoggerName
_loname LOMeta
_ LOContent LoggerName
lc) ->
    MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
locallock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ ->
        case LOContent LoggerName
lc of
            (LogMessage LoggerName
logItem) ->
                    LoggerName -> LoggerName -> IO ()
output LoggerName
ctx LoggerName
logItem
            LOContent LoggerName
obj ->
                    LoggerName -> LoggerName -> IO ()
output LoggerName
ctx (LoggerName -> IO ()) -> LoggerName -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> LoggerName
toStrict (LOContent LoggerName -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText LOContent LoggerName
obj)
  where
    output :: LoggerName -> LoggerName -> IO ()
output LoggerName
nm LoggerName
msg = LoggerName -> IO ()
TIO.putStrLn (LoggerName -> IO ()) -> LoggerName -> IO ()
forall a b. (a -> b) -> a -> b
$ LoggerName
nm LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
" :: " LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> LoggerName
msg

\end{code}


\subsubsection{Concrete Trace into a |TVar|}\label{code:traceInTVar}\label{code:traceInTVarIO}\index{traceInTVar}\index{traceInTVarIO}

\begin{code}
traceInTVar :: STM.TVar [a] -> Tracer STM.STM a
traceInTVar :: TVar [a] -> Tracer STM a
traceInTVar TVar [a]
tvar = (a -> STM ()) -> Tracer STM a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> STM ()) -> Tracer STM a) -> (a -> STM ()) -> Tracer STM a
forall a b. (a -> b) -> a -> b
$ \a
a -> TVar [a] -> ([a] -> [a]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar TVar [a]
tvar ((:) a
a)

traceInTVarIO :: STM.TVar [a] -> Tracer IO a
traceInTVarIO :: TVar [a] -> Tracer IO a
traceInTVarIO TVar [a]
tvar = (a -> IO ()) -> Tracer IO a
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((a -> IO ()) -> Tracer IO a) -> (a -> IO ()) -> Tracer IO a
forall a b. (a -> b) -> a -> b
$ \a
a ->
                         STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [a] -> ([a] -> [a]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
STM.modifyTVar TVar [a]
tvar ((:) a
a)

\end{code}

\subsubsection{Enter message into a trace}\label{code:traceNamedItem}\index{traceNamedItem}
The function |traceNamedItem| creates a |LogObject| and threads this through
the action defined in the |Trace|.

\begin{code}
traceNamedItem
    :: MonadIO m
    => Trace m a
    -> PrivacyAnnotation
    -> Severity
    -> a
    -> m ()
traceNamedItem :: Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
p Severity
s a
m =
    Trace m a -> (LOMeta, LOContent a) -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> (LOMeta, LOContent a) -> m ()
traceNamedObject Trace m a
logTrace ((LOMeta, LOContent a) -> m ()) -> m (LOMeta, LOContent a) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        (,) (LOMeta -> LOContent a -> (LOMeta, LOContent a))
-> m LOMeta -> m (LOContent a -> (LOMeta, LOContent a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO LOMeta -> m LOMeta
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
s PrivacyAnnotation
p)
            m (LOContent a -> (LOMeta, LOContent a))
-> m (LOContent a) -> m (LOMeta, LOContent a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LOContent a -> m (LOContent a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> LOContent a
forall a. a -> LOContent a
LogMessage a
m)

\end{code}

\subsubsection{Logging functions}
\label{code:logDebug}\index{logDebug}
\label{code:logDebugS}\index{logDebugS}
\label{code:logInfo}\index{logInfo}
\label{code:logInfoS}\index{logInfoS}
\label{code:logNotice}\index{logNotice}
\label{code:logNoticeS}\index{logNoticeS}
\label{code:logWarning}\index{logWarning}
\label{code:logWarningS}\index{logWarningS}
\label{code:logError}\index{logError}
\label{code:logErrorS}\index{logErrorS}
\label{code:logCritical}\index{logCritical}
\label{code:logCriticalS}\index{logCriticalS}
\label{code:logAlert}\index{logAlert}
\label{code:logAlertS}\index{logAlertS}
\label{code:logEmergency}\index{logEmergency}
\label{code:logEmergencyS}\index{logEmergencyS}
\begin{code}
logDebug, logInfo, logNotice, logWarning, logError, logCritical, logAlert, logEmergency
    :: MonadIO m => Trace m a -> a -> m ()
logDebug :: Trace m a -> a -> m ()
logDebug     Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Public Severity
Debug
logInfo :: Trace m a -> a -> m ()
logInfo      Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Public Severity
Info
logNotice :: Trace m a -> a -> m ()
logNotice    Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Public Severity
Notice
logWarning :: Trace m a -> a -> m ()
logWarning   Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Public Severity
Warning
logError :: Trace m a -> a -> m ()
logError     Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Public Severity
Error
logCritical :: Trace m a -> a -> m ()
logCritical  Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Public Severity
Critical
logAlert :: Trace m a -> a -> m ()
logAlert     Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Public Severity
Alert
logEmergency :: Trace m a -> a -> m ()
logEmergency Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Public Severity
Emergency

logDebugS, logInfoS, logNoticeS, logWarningS, logErrorS, logCriticalS, logAlertS, logEmergencyS
    :: MonadIO m => Trace m a -> a -> m ()
logDebugS :: Trace m a -> a -> m ()
logDebugS     Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Confidential Severity
Debug
logInfoS :: Trace m a -> a -> m ()
logInfoS      Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Confidential Severity
Info
logNoticeS :: Trace m a -> a -> m ()
logNoticeS    Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Confidential Severity
Notice
logWarningS :: Trace m a -> a -> m ()
logWarningS   Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Confidential Severity
Warning
logErrorS :: Trace m a -> a -> m ()
logErrorS     Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Confidential Severity
Error
logCriticalS :: Trace m a -> a -> m ()
logCriticalS  Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Confidential Severity
Critical
logAlertS :: Trace m a -> a -> m ()
logAlertS     Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Confidential Severity
Alert
logEmergencyS :: Trace m a -> a -> m ()
logEmergencyS Trace m a
logTrace = Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
forall (m :: * -> *) a.
MonadIO m =>
Trace m a -> PrivacyAnnotation -> Severity -> a -> m ()
traceNamedItem Trace m a
logTrace PrivacyAnnotation
Confidential Severity
Emergency

\end{code}