{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts   #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RankNTypes         #-}
{-# LANGUAGE StrictData         #-}
{-# LANGUAGE TemplateHaskell    #-}
{-# LANGUAGE TypeApplications   #-}
{-# LANGUAGE TypeOperators      #-}

module Control.Monad.Freer.Extras.Log (

    -- $log
    -- * Logging functions
    LogMsg(..)
    , LogLevel(..)
    , LogMessage(..)
    , logLevel
    , logMessageContent
    , logMessage
    , logDebug
    , logInfo
    , logWarn
    , logError

    -- * Modifying logs
    , mapLog
    , mapMLog

    -- * Running logs
    , handleWriterLog
    , handleLogIgnore
    , handleLogTrace
    , handleLogWriter
    , renderLogMessages

    -- * Observing
    , LogObserve(..)
    , ObservationHandle
    , Observation(..)
    , observeBefore
    , observeAfter

     -- * Combinators
    , surround
    , surroundDebug
    , surroundInfo
    , surroundWarn

    -- ** Handlers
    , handleObserveLog
    , handleObserve
    ) where

import Control.Monad.Freer.Extras.Modify (raiseUnder)

import Control.Lens (AReview, Prism', makeLenses, prism', review)
import Control.Monad.Freer
import Control.Monad.Freer.State (State, get, put, runState)
import Control.Monad.Freer.TH (makeEffect)
import Control.Monad.Freer.Writer (Writer (..), tell)
import Data.Aeson (FromJSON, ToJSON)
import Data.Foldable (for_, traverse_)
import Data.Text (Text)
import Debug.Trace qualified as Trace
import GHC.Generics (Generic)
import Prettyprinter hiding (surround)
import Prettyprinter.Render.String qualified as Render
import Prettyprinter.Render.Text qualified as Render

-- $log
-- This module provides effects and handlers for structured logging and
-- tracing.

{- Note [Logging and Tracing]

This module provides two effects for structured logging, implementing a
'freer-simple' version of https://github.com/input-output-hk/iohk-monitoring-framework/tree/master/contra-tracer.

* 'LogMsg' and its handlers correspond to 'Control.Tracer'
* 'LogObserve' and its handler correspond to 'Control.Tracer.Observe'

= LogMsg

When using 'Control.Tracer' with mtl-style effects, we usually have a
'Tracer m s' at the top level with a sum type @s@, and we can use
'contramap' to get tracers for the finer-grained message
types.

In this module we have 'Member (LogMsg s) effs' instead of the 'Tracer m s'
value. With 'freer' effects we can have many instances of 'LogMsg' in our
effects stack so we don't need to call 'contramap' or similar on
the client side. The conversion to @s@ happens in the big effect handler that
discharges all the 'LogMsg' effects.

= LogObserve

'LogObserve' is an effect for taking measurements before and after an action,
and recording the difference between them. It is implemented using two markers,
'LObserveBefore' and 'LObserveAfter'.

Some effects such as Error, Prompt may short-circuit the action, so that the
LObserveAfter marker is never encountered by the handler. 'handleObserve' deals
with this by keeping a stack of unmatched 'LObserveBefore' markers and popping
as many items of the stack as needed whenever 'LObserveAfter' is run. It works
even if the topmost LObserveAfter is never seen, by popping all remaining items
off the stack at the end.

'LogObserve' supports measures taken on the call site and on the
interpretation site.

* Interpretation-site measures are produced with the second argument to
  'handleObserve'
* Call-site measures can be provided using the type parameter a in the
  constructors of 'LogObserve'

-}

data LogMsg a r where
    LMessage :: LogMessage a -> LogMsg a ()

-- | An abstract type used to tie the beginning and end of observations
--   together.
newtype ObservationHandle = ObservationHandle Integer

data LogObserve a r where
    ObserveBefore :: a -> LogObserve a ObservationHandle
    ObserveAfter  :: Maybe a -> ObservationHandle -> LogObserve a ()

-- | The severity level of a log message
--   See https://en.wikipedia.org/wiki/Syslog#Severity_level
data LogLevel =
        Debug
        | Info
        | Notice
        | Warning
        | Error
        | Critical
        | Alert
        | Emergency
    deriving stock (Int -> LogLevel -> ShowS
[LogLevel] -> ShowS
LogLevel -> String
(Int -> LogLevel -> ShowS)
-> (LogLevel -> String) -> ([LogLevel] -> ShowS) -> Show LogLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogLevel] -> ShowS
$cshowList :: [LogLevel] -> ShowS
show :: LogLevel -> String
$cshow :: LogLevel -> String
showsPrec :: Int -> LogLevel -> ShowS
$cshowsPrec :: Int -> LogLevel -> ShowS
Show, LogLevel -> LogLevel -> Bool
(LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool) -> Eq LogLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogLevel -> LogLevel -> Bool
$c/= :: LogLevel -> LogLevel -> Bool
== :: LogLevel -> LogLevel -> Bool
$c== :: LogLevel -> LogLevel -> Bool
Eq, Eq LogLevel
Eq LogLevel
-> (LogLevel -> LogLevel -> Ordering)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> Bool)
-> (LogLevel -> LogLevel -> LogLevel)
-> (LogLevel -> LogLevel -> LogLevel)
-> Ord LogLevel
LogLevel -> LogLevel -> Bool
LogLevel -> LogLevel -> Ordering
LogLevel -> LogLevel -> LogLevel
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LogLevel -> LogLevel -> LogLevel
$cmin :: LogLevel -> LogLevel -> LogLevel
max :: LogLevel -> LogLevel -> LogLevel
$cmax :: LogLevel -> LogLevel -> LogLevel
>= :: LogLevel -> LogLevel -> Bool
$c>= :: LogLevel -> LogLevel -> Bool
> :: LogLevel -> LogLevel -> Bool
$c> :: LogLevel -> LogLevel -> Bool
<= :: LogLevel -> LogLevel -> Bool
$c<= :: LogLevel -> LogLevel -> Bool
< :: LogLevel -> LogLevel -> Bool
$c< :: LogLevel -> LogLevel -> Bool
compare :: LogLevel -> LogLevel -> Ordering
$ccompare :: LogLevel -> LogLevel -> Ordering
$cp1Ord :: Eq LogLevel
Ord, (forall x. LogLevel -> Rep LogLevel x)
-> (forall x. Rep LogLevel x -> LogLevel) -> Generic LogLevel
forall x. Rep LogLevel x -> LogLevel
forall x. LogLevel -> Rep LogLevel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LogLevel x -> LogLevel
$cfrom :: forall x. LogLevel -> Rep LogLevel x
Generic)
    deriving anyclass ([LogLevel] -> Value
[LogLevel] -> Encoding
LogLevel -> Value
LogLevel -> Encoding
(LogLevel -> Value)
-> (LogLevel -> Encoding)
-> ([LogLevel] -> Value)
-> ([LogLevel] -> Encoding)
-> ToJSON LogLevel
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [LogLevel] -> Encoding
$ctoEncodingList :: [LogLevel] -> Encoding
toJSONList :: [LogLevel] -> Value
$ctoJSONList :: [LogLevel] -> Value
toEncoding :: LogLevel -> Encoding
$ctoEncoding :: LogLevel -> Encoding
toJSON :: LogLevel -> Value
$ctoJSON :: LogLevel -> Value
ToJSON, Value -> Parser [LogLevel]
Value -> Parser LogLevel
(Value -> Parser LogLevel)
-> (Value -> Parser [LogLevel]) -> FromJSON LogLevel
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [LogLevel]
$cparseJSONList :: Value -> Parser [LogLevel]
parseJSON :: Value -> Parser LogLevel
$cparseJSON :: Value -> Parser LogLevel
FromJSON)

instance Pretty LogLevel where
    pretty :: LogLevel -> Doc ann
pretty = \case
        LogLevel
Debug     -> Doc ann
"[DEBUG]"
        LogLevel
Info      -> Doc ann
"[INFO]"
        LogLevel
Notice    -> Doc ann
"[NOTICE]"
        LogLevel
Warning   -> Doc ann
"[WARNING]"
        LogLevel
Error     -> Doc ann
"[ERROR]"
        LogLevel
Critical  -> Doc ann
"[CRITICAL]"
        LogLevel
Alert     -> Doc ann
"[ALERT]"
        LogLevel
Emergency -> Doc ann
"[EMERGENCY]"

data LogMessage a = LogMessage { LogMessage a -> LogLevel
_logLevel :: LogLevel, LogMessage a -> a
_logMessageContent :: a }
    deriving stock (Int -> LogMessage a -> ShowS
[LogMessage a] -> ShowS
LogMessage a -> String
(Int -> LogMessage a -> ShowS)
-> (LogMessage a -> String)
-> ([LogMessage a] -> ShowS)
-> Show (LogMessage a)
forall a. Show a => Int -> LogMessage a -> ShowS
forall a. Show a => [LogMessage a] -> ShowS
forall a. Show a => LogMessage a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogMessage a] -> ShowS
$cshowList :: forall a. Show a => [LogMessage a] -> ShowS
show :: LogMessage a -> String
$cshow :: forall a. Show a => LogMessage a -> String
showsPrec :: Int -> LogMessage a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> LogMessage a -> ShowS
Show, LogMessage a -> LogMessage a -> Bool
(LogMessage a -> LogMessage a -> Bool)
-> (LogMessage a -> LogMessage a -> Bool) -> Eq (LogMessage a)
forall a. Eq a => LogMessage a -> LogMessage a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogMessage a -> LogMessage a -> Bool
$c/= :: forall a. Eq a => LogMessage a -> LogMessage a -> Bool
== :: LogMessage a -> LogMessage a -> Bool
$c== :: forall a. Eq a => LogMessage a -> LogMessage a -> Bool
Eq, Eq (LogMessage a)
Eq (LogMessage a)
-> (LogMessage a -> LogMessage a -> Ordering)
-> (LogMessage a -> LogMessage a -> Bool)
-> (LogMessage a -> LogMessage a -> Bool)
-> (LogMessage a -> LogMessage a -> Bool)
-> (LogMessage a -> LogMessage a -> Bool)
-> (LogMessage a -> LogMessage a -> LogMessage a)
-> (LogMessage a -> LogMessage a -> LogMessage a)
-> Ord (LogMessage a)
LogMessage a -> LogMessage a -> Bool
LogMessage a -> LogMessage a -> Ordering
LogMessage a -> LogMessage a -> LogMessage a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (LogMessage a)
forall a. Ord a => LogMessage a -> LogMessage a -> Bool
forall a. Ord a => LogMessage a -> LogMessage a -> Ordering
forall a. Ord a => LogMessage a -> LogMessage a -> LogMessage a
min :: LogMessage a -> LogMessage a -> LogMessage a
$cmin :: forall a. Ord a => LogMessage a -> LogMessage a -> LogMessage a
max :: LogMessage a -> LogMessage a -> LogMessage a
$cmax :: forall a. Ord a => LogMessage a -> LogMessage a -> LogMessage a
>= :: LogMessage a -> LogMessage a -> Bool
$c>= :: forall a. Ord a => LogMessage a -> LogMessage a -> Bool
> :: LogMessage a -> LogMessage a -> Bool
$c> :: forall a. Ord a => LogMessage a -> LogMessage a -> Bool
<= :: LogMessage a -> LogMessage a -> Bool
$c<= :: forall a. Ord a => LogMessage a -> LogMessage a -> Bool
< :: LogMessage a -> LogMessage a -> Bool
$c< :: forall a. Ord a => LogMessage a -> LogMessage a -> Bool
compare :: LogMessage a -> LogMessage a -> Ordering
$ccompare :: forall a. Ord a => LogMessage a -> LogMessage a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (LogMessage a)
Ord, (forall x. LogMessage a -> Rep (LogMessage a) x)
-> (forall x. Rep (LogMessage a) x -> LogMessage a)
-> Generic (LogMessage a)
forall x. Rep (LogMessage a) x -> LogMessage a
forall x. LogMessage a -> Rep (LogMessage a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (LogMessage a) x -> LogMessage a
forall a x. LogMessage a -> Rep (LogMessage a) x
$cto :: forall a x. Rep (LogMessage a) x -> LogMessage a
$cfrom :: forall a x. LogMessage a -> Rep (LogMessage a) x
Generic, a -> LogMessage b -> LogMessage a
(a -> b) -> LogMessage a -> LogMessage b
(forall a b. (a -> b) -> LogMessage a -> LogMessage b)
-> (forall a b. a -> LogMessage b -> LogMessage a)
-> Functor LogMessage
forall a b. a -> LogMessage b -> LogMessage a
forall a b. (a -> b) -> LogMessage a -> LogMessage b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LogMessage b -> LogMessage a
$c<$ :: forall a b. a -> LogMessage b -> LogMessage a
fmap :: (a -> b) -> LogMessage a -> LogMessage b
$cfmap :: forall a b. (a -> b) -> LogMessage a -> LogMessage b
Functor, LogMessage a -> Bool
(a -> m) -> LogMessage a -> m
(a -> b -> b) -> b -> LogMessage a -> b
(forall m. Monoid m => LogMessage m -> m)
-> (forall m a. Monoid m => (a -> m) -> LogMessage a -> m)
-> (forall m a. Monoid m => (a -> m) -> LogMessage a -> m)
-> (forall a b. (a -> b -> b) -> b -> LogMessage a -> b)
-> (forall a b. (a -> b -> b) -> b -> LogMessage a -> b)
-> (forall b a. (b -> a -> b) -> b -> LogMessage a -> b)
-> (forall b a. (b -> a -> b) -> b -> LogMessage a -> b)
-> (forall a. (a -> a -> a) -> LogMessage a -> a)
-> (forall a. (a -> a -> a) -> LogMessage a -> a)
-> (forall a. LogMessage a -> [a])
-> (forall a. LogMessage a -> Bool)
-> (forall a. LogMessage a -> Int)
-> (forall a. Eq a => a -> LogMessage a -> Bool)
-> (forall a. Ord a => LogMessage a -> a)
-> (forall a. Ord a => LogMessage a -> a)
-> (forall a. Num a => LogMessage a -> a)
-> (forall a. Num a => LogMessage a -> a)
-> Foldable LogMessage
forall a. Eq a => a -> LogMessage a -> Bool
forall a. Num a => LogMessage a -> a
forall a. Ord a => LogMessage a -> a
forall m. Monoid m => LogMessage m -> m
forall a. LogMessage a -> Bool
forall a. LogMessage a -> Int
forall a. LogMessage a -> [a]
forall a. (a -> a -> a) -> LogMessage a -> a
forall m a. Monoid m => (a -> m) -> LogMessage a -> m
forall b a. (b -> a -> b) -> b -> LogMessage a -> b
forall a b. (a -> b -> b) -> b -> LogMessage a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: LogMessage a -> a
$cproduct :: forall a. Num a => LogMessage a -> a
sum :: LogMessage a -> a
$csum :: forall a. Num a => LogMessage a -> a
minimum :: LogMessage a -> a
$cminimum :: forall a. Ord a => LogMessage a -> a
maximum :: LogMessage a -> a
$cmaximum :: forall a. Ord a => LogMessage a -> a
elem :: a -> LogMessage a -> Bool
$celem :: forall a. Eq a => a -> LogMessage a -> Bool
length :: LogMessage a -> Int
$clength :: forall a. LogMessage a -> Int
null :: LogMessage a -> Bool
$cnull :: forall a. LogMessage a -> Bool
toList :: LogMessage a -> [a]
$ctoList :: forall a. LogMessage a -> [a]
foldl1 :: (a -> a -> a) -> LogMessage a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> LogMessage a -> a
foldr1 :: (a -> a -> a) -> LogMessage a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> LogMessage a -> a
foldl' :: (b -> a -> b) -> b -> LogMessage a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> LogMessage a -> b
foldl :: (b -> a -> b) -> b -> LogMessage a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> LogMessage a -> b
foldr' :: (a -> b -> b) -> b -> LogMessage a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> LogMessage a -> b
foldr :: (a -> b -> b) -> b -> LogMessage a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> LogMessage a -> b
foldMap' :: (a -> m) -> LogMessage a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> LogMessage a -> m
foldMap :: (a -> m) -> LogMessage a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> LogMessage a -> m
fold :: LogMessage m -> m
$cfold :: forall m. Monoid m => LogMessage m -> m
Foldable, Functor LogMessage
Foldable LogMessage
Functor LogMessage
-> Foldable LogMessage
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> LogMessage a -> f (LogMessage b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    LogMessage (f a) -> f (LogMessage a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> LogMessage a -> m (LogMessage b))
-> (forall (m :: * -> *) a.
    Monad m =>
    LogMessage (m a) -> m (LogMessage a))
-> Traversable LogMessage
(a -> f b) -> LogMessage a -> f (LogMessage b)
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
LogMessage (m a) -> m (LogMessage a)
forall (f :: * -> *) a.
Applicative f =>
LogMessage (f a) -> f (LogMessage a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LogMessage a -> m (LogMessage b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LogMessage a -> f (LogMessage b)
sequence :: LogMessage (m a) -> m (LogMessage a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
LogMessage (m a) -> m (LogMessage a)
mapM :: (a -> m b) -> LogMessage a -> m (LogMessage b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> LogMessage a -> m (LogMessage b)
sequenceA :: LogMessage (f a) -> f (LogMessage a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
LogMessage (f a) -> f (LogMessage a)
traverse :: (a -> f b) -> LogMessage a -> f (LogMessage b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> LogMessage a -> f (LogMessage b)
$cp2Traversable :: Foldable LogMessage
$cp1Traversable :: Functor LogMessage
Traversable)
    deriving anyclass ([LogMessage a] -> Value
[LogMessage a] -> Encoding
LogMessage a -> Value
LogMessage a -> Encoding
(LogMessage a -> Value)
-> (LogMessage a -> Encoding)
-> ([LogMessage a] -> Value)
-> ([LogMessage a] -> Encoding)
-> ToJSON (LogMessage a)
forall a. ToJSON a => [LogMessage a] -> Value
forall a. ToJSON a => [LogMessage a] -> Encoding
forall a. ToJSON a => LogMessage a -> Value
forall a. ToJSON a => LogMessage a -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [LogMessage a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [LogMessage a] -> Encoding
toJSONList :: [LogMessage a] -> Value
$ctoJSONList :: forall a. ToJSON a => [LogMessage a] -> Value
toEncoding :: LogMessage a -> Encoding
$ctoEncoding :: forall a. ToJSON a => LogMessage a -> Encoding
toJSON :: LogMessage a -> Value
$ctoJSON :: forall a. ToJSON a => LogMessage a -> Value
ToJSON, Value -> Parser [LogMessage a]
Value -> Parser (LogMessage a)
(Value -> Parser (LogMessage a))
-> (Value -> Parser [LogMessage a]) -> FromJSON (LogMessage a)
forall a. FromJSON a => Value -> Parser [LogMessage a]
forall a. FromJSON a => Value -> Parser (LogMessage a)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [LogMessage a]
$cparseJSONList :: forall a. FromJSON a => Value -> Parser [LogMessage a]
parseJSON :: Value -> Parser (LogMessage a)
$cparseJSON :: forall a. FromJSON a => Value -> Parser (LogMessage a)
FromJSON)

makeLenses ''LogMessage

logMessage :: LogLevel -> Prism' (LogMessage a) a
logMessage :: LogLevel -> Prism' (LogMessage a) a
logMessage LogLevel
lvl = (a -> LogMessage a)
-> (LogMessage a -> Maybe a) -> Prism' (LogMessage a) a
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (LogLevel -> a -> LogMessage a
forall a. LogLevel -> a -> LogMessage a
LogMessage LogLevel
lvl) (\case { LogMessage LogLevel
lvl' a
a | LogLevel
lvl' LogLevel -> LogLevel -> Bool
forall a. Eq a => a -> a -> Bool
== LogLevel
lvl -> a -> Maybe a
forall a. a -> Maybe a
Just a
a; LogMessage a
_ -> Maybe a
forall a. Maybe a
Nothing})

instance Pretty a => Pretty (LogMessage a) where
    pretty :: LogMessage a -> Doc ann
pretty LogMessage{LogLevel
_logLevel :: LogLevel
_logLevel :: forall a. LogMessage a -> LogLevel
_logLevel, a
_logMessageContent :: a
_logMessageContent :: forall a. LogMessage a -> a
_logMessageContent} =
        LogLevel -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty LogLevel
_logLevel Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
hang Int
0 (a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty a
_logMessageContent)

logDebug :: forall a effs. Member (LogMsg a) effs => a -> Eff effs ()
logDebug :: a -> Eff effs ()
logDebug a
m = LogMsg a () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg a () -> Eff effs ()) -> LogMsg a () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ LogMessage a -> LogMsg a ()
forall a. LogMessage a -> LogMsg a ()
LMessage (LogLevel -> a -> LogMessage a
forall a. LogLevel -> a -> LogMessage a
LogMessage LogLevel
Debug a
m)

logWarn :: forall a effs. Member (LogMsg a) effs => a -> Eff effs ()
logWarn :: a -> Eff effs ()
logWarn a
m = LogMsg a () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg a () -> Eff effs ()) -> LogMsg a () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ LogMessage a -> LogMsg a ()
forall a. LogMessage a -> LogMsg a ()
LMessage (LogLevel -> a -> LogMessage a
forall a. LogLevel -> a -> LogMessage a
LogMessage LogLevel
Warning a
m)

logInfo :: forall a effs. Member (LogMsg a) effs => a -> Eff effs ()
logInfo :: a -> Eff effs ()
logInfo a
m = LogMsg a () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg a () -> Eff effs ()) -> LogMsg a () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ LogMessage a -> LogMsg a ()
forall a. LogMessage a -> LogMsg a ()
LMessage (LogLevel -> a -> LogMessage a
forall a. LogLevel -> a -> LogMessage a
LogMessage LogLevel
Info a
m)

logError :: forall a effs. Member (LogMsg a) effs => a -> Eff effs ()
logError :: a -> Eff effs ()
logError a
m = LogMsg a () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg a () -> Eff effs ()) -> LogMsg a () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ LogMessage a -> LogMsg a ()
forall a. LogMessage a -> LogMsg a ()
LMessage (LogLevel -> a -> LogMessage a
forall a. LogLevel -> a -> LogMessage a
LogMessage LogLevel
Error a
m)

-- | Re-interpret a logging effect by mapping the
--   log messages.
--   (Does the same thing as 'Covariant.contramap' for
--   'Control.Tracer.Trace')
mapLog ::
    forall a b effs.
    Member (LogMsg b) effs
    => (a -> b)
    -> LogMsg a
    ~> Eff effs
mapLog :: (a -> b) -> LogMsg a ~> Eff effs
mapLog a -> b
f = \case
    LMessage LogMessage a
msg -> LogMsg b () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg b () -> Eff effs ()) -> LogMsg b () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ LogMessage b -> LogMsg b ()
forall a. LogMessage a -> LogMsg a ()
LMessage ((a -> b) -> LogMessage a -> LogMessage b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f LogMessage a
msg)

-- | Re-interpret a logging effect by mapping the
--   log messages. Can use other effects.
mapMLog ::
    forall a b effs.
    Member (LogMsg b) effs
    => (a -> Eff effs b)
    -> LogMsg a
    ~> Eff effs
mapMLog :: (a -> Eff effs b) -> LogMsg a ~> Eff effs
mapMLog a -> Eff effs b
f = \case
    LMessage LogMessage a
msg -> (a -> Eff effs b) -> LogMessage a -> Eff effs (LogMessage b)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> Eff effs b
f LogMessage a
msg Eff effs (LogMessage b)
-> (LogMessage b -> Eff effs ()) -> Eff effs ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LogMsg b () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg b () -> Eff effs ())
-> (LogMessage b -> LogMsg b ()) -> LogMessage b -> Eff effs ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage b -> LogMsg b ()
forall a. LogMessage a -> LogMsg a ()
LMessage

-- | Pretty-print the log messages
renderLogMessages ::
    forall a effs.
    ( Member (LogMsg Text) effs
    , Pretty a
    )
    => LogMsg a
    ~> Eff effs
renderLogMessages :: LogMsg a ~> Eff effs
renderLogMessages =
    (a -> Text) -> LogMsg a ~> Eff effs
forall a b (effs :: [* -> *]).
Member (LogMsg b) effs =>
(a -> b) -> LogMsg a ~> Eff effs
mapLog (SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
Render.renderStrict (SimpleDocStream Any -> Text)
-> (a -> SimpleDocStream Any) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any)
-> (a -> Doc Any) -> a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty)

-- | Re-interpret a 'Writer' effect by writing the events to the log
handleWriterLog ::
    forall a f effs.
    ( Member (LogMsg a) effs
    , Traversable f
    )
    => (a -> LogLevel)
    -> Eff (Writer (f a) ': effs)
    ~> Eff effs
handleWriterLog :: (a -> LogLevel) -> Eff (Writer (f a) : effs) ~> Eff effs
handleWriterLog a -> LogLevel
f = (Writer (f a) ~> Eff effs) -> Eff (Writer (f a) : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((Writer (f a) ~> Eff effs)
 -> Eff (Writer (f a) : effs) ~> Eff effs)
-> (Writer (f a) ~> Eff effs)
-> Eff (Writer (f a) : effs) ~> Eff effs
forall a b. (a -> b) -> a -> b
$ \case
    Tell es -> (a -> Eff effs ()) -> f a -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (\a
a -> LogMsg a () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg a () -> Eff effs ()) -> LogMsg a () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ LogMessage a -> LogMsg a ()
forall a. LogMessage a -> LogMsg a ()
LMessage (LogMessage a -> LogMsg a ()) -> LogMessage a -> LogMsg a ()
forall a b. (a -> b) -> a -> b
$ LogLevel -> a -> LogMessage a
forall a. LogLevel -> a -> LogMessage a
LogMessage (a -> LogLevel
f a
a) a
a) f a
es

-- | Re-interpret a 'Log' effect with a 'Writer'
handleLogWriter ::
    forall a w effs.
    ( Member (Writer w) effs
    )
    => AReview w (LogMessage a)
    -> LogMsg a
    ~> Eff effs
handleLogWriter :: AReview w (LogMessage a) -> LogMsg a ~> Eff effs
handleLogWriter AReview w (LogMessage a)
p = \case
    LMessage LogMessage a
msg -> w -> Eff effs ()
forall w (effs :: [* -> *]).
Member (Writer w) effs =>
w -> Eff effs ()
tell @w (AReview w (LogMessage a) -> LogMessage a -> w
forall b (m :: * -> *) t. MonadReader b m => AReview t b -> m t
review AReview w (LogMessage a)
p LogMessage a
msg)

-- | Ignore all log messages.
handleLogIgnore :: Eff (LogMsg a ': effs) ~> Eff effs
handleLogIgnore :: Eff (LogMsg a : effs) x -> Eff effs x
handleLogIgnore = (LogMsg a ~> Eff effs) -> Eff (LogMsg a : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((LogMsg a ~> Eff effs) -> Eff (LogMsg a : effs) ~> Eff effs)
-> (LogMsg a ~> Eff effs) -> Eff (LogMsg a : effs) ~> Eff effs
forall a b. (a -> b) -> a -> b
$ \case
    LMessage _ -> () -> Eff effs ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Write the log to stdout using 'Debug.Trace.trace'
handleLogTrace :: Pretty a => Eff (LogMsg a ': effs) ~> Eff effs
handleLogTrace :: Eff (LogMsg a : effs) ~> Eff effs
handleLogTrace = (LogMsg a ~> Eff effs) -> Eff (LogMsg a : effs) ~> Eff effs
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((LogMsg a ~> Eff effs) -> Eff (LogMsg a : effs) ~> Eff effs)
-> (LogMsg a ~> Eff effs) -> Eff (LogMsg a : effs) ~> Eff effs
forall a b. (a -> b) -> a -> b
$ \case
    LMessage msg -> String -> Eff effs () -> Eff effs ()
forall a. String -> a -> a
Trace.trace (SimpleDocStream Any -> String
forall ann. SimpleDocStream ann -> String
Render.renderString (SimpleDocStream Any -> String)
-> (LogMessage a -> SimpleDocStream Any) -> LogMessage a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
layoutPretty LayoutOptions
defaultLayoutOptions (Doc Any -> SimpleDocStream Any)
-> (LogMessage a -> Doc Any) -> LogMessage a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogMessage a -> Doc Any
forall a ann. Pretty a => a -> Doc ann
pretty (LogMessage a -> String) -> LogMessage a -> String
forall a b. (a -> b) -> a -> b
$ LogMessage a
msg) (() -> Eff effs ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Write a log message before and after an action. Consider using
--   'observeBefore' and 'observeAfter' directly if you need more control
--   over the values that are observed at the call site.
surround :: forall v a effs. Member (LogObserve v) effs => v -> Eff effs a -> Eff effs a
surround :: v -> Eff effs a -> Eff effs a
surround v
v Eff effs a
action = do
    ObservationHandle
i <- LogObserve v ObservationHandle -> Eff effs ObservationHandle
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogObserve v ObservationHandle -> Eff effs ObservationHandle)
-> LogObserve v ObservationHandle -> Eff effs ObservationHandle
forall a b. (a -> b) -> a -> b
$ v -> LogObserve v ObservationHandle
forall a. a -> LogObserve a ObservationHandle
ObserveBefore v
v
    a
result <- Eff effs a
action
    forall (effs :: [* -> *]) a.
Member (LogObserve v) effs =>
LogObserve v a -> Eff effs a
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(LogObserve v) (LogObserve v () -> Eff effs ()) -> LogObserve v () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ Maybe v -> ObservationHandle -> LogObserve v ()
forall a. Maybe a -> ObservationHandle -> LogObserve a ()
ObserveAfter Maybe v
forall a. Maybe a
Nothing ObservationHandle
i
    a -> Eff effs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

-- | @surroundInfo = surround Info@
surroundInfo :: Member (LogObserve (LogMessage v)) effs => v -> Eff effs a -> Eff effs a
surroundInfo :: v -> Eff effs a -> Eff effs a
surroundInfo = LogMessage v -> Eff effs a -> Eff effs a
forall v a (effs :: [* -> *]).
Member (LogObserve v) effs =>
v -> Eff effs a -> Eff effs a
surround (LogMessage v -> Eff effs a -> Eff effs a)
-> (v -> LogMessage v) -> v -> Eff effs a -> Eff effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> v -> LogMessage v
forall a. LogLevel -> a -> LogMessage a
LogMessage LogLevel
Info

-- | @surroundDebug = surround Debug@
surroundDebug :: Member (LogObserve (LogMessage v)) effs => v -> Eff effs a -> Eff effs a
surroundDebug :: v -> Eff effs a -> Eff effs a
surroundDebug = LogMessage v -> Eff effs a -> Eff effs a
forall v a (effs :: [* -> *]).
Member (LogObserve v) effs =>
v -> Eff effs a -> Eff effs a
surround (LogMessage v -> Eff effs a -> Eff effs a)
-> (v -> LogMessage v) -> v -> Eff effs a -> Eff effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> v -> LogMessage v
forall a. LogLevel -> a -> LogMessage a
LogMessage LogLevel
Debug

-- | @surroundWarn = surround Warn@
surroundWarn :: Member (LogObserve (LogMessage v)) effs => v -> Eff effs a -> Eff effs a
surroundWarn :: v -> Eff effs a -> Eff effs a
surroundWarn = LogMessage v -> Eff effs a -> Eff effs a
forall v a (effs :: [* -> *]).
Member (LogObserve v) effs =>
v -> Eff effs a -> Eff effs a
surround (LogMessage v -> Eff effs a -> Eff effs a)
-> (v -> LogMessage v) -> v -> Eff effs a -> Eff effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> v -> LogMessage v
forall a. LogLevel -> a -> LogMessage a
LogMessage LogLevel
Warning

-- | How did the observed action end
data ExitMode =
    Regular -- ^ The action was run to completion
    | Irregular -- ^ Execution of the observed action was cut short. This can happen if you use 'LogObserve' in combination with 'Error', 'NonDet', 'Prompt' or similar effects.
    deriving (ExitMode -> ExitMode -> Bool
(ExitMode -> ExitMode -> Bool)
-> (ExitMode -> ExitMode -> Bool) -> Eq ExitMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ExitMode -> ExitMode -> Bool
$c/= :: ExitMode -> ExitMode -> Bool
== :: ExitMode -> ExitMode -> Bool
$c== :: ExitMode -> ExitMode -> Bool
Eq, Eq ExitMode
Eq ExitMode
-> (ExitMode -> ExitMode -> Ordering)
-> (ExitMode -> ExitMode -> Bool)
-> (ExitMode -> ExitMode -> Bool)
-> (ExitMode -> ExitMode -> Bool)
-> (ExitMode -> ExitMode -> Bool)
-> (ExitMode -> ExitMode -> ExitMode)
-> (ExitMode -> ExitMode -> ExitMode)
-> Ord ExitMode
ExitMode -> ExitMode -> Bool
ExitMode -> ExitMode -> Ordering
ExitMode -> ExitMode -> ExitMode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ExitMode -> ExitMode -> ExitMode
$cmin :: ExitMode -> ExitMode -> ExitMode
max :: ExitMode -> ExitMode -> ExitMode
$cmax :: ExitMode -> ExitMode -> ExitMode
>= :: ExitMode -> ExitMode -> Bool
$c>= :: ExitMode -> ExitMode -> Bool
> :: ExitMode -> ExitMode -> Bool
$c> :: ExitMode -> ExitMode -> Bool
<= :: ExitMode -> ExitMode -> Bool
$c<= :: ExitMode -> ExitMode -> Bool
< :: ExitMode -> ExitMode -> Bool
$c< :: ExitMode -> ExitMode -> Bool
compare :: ExitMode -> ExitMode -> Ordering
$ccompare :: ExitMode -> ExitMode -> Ordering
$cp1Ord :: Eq ExitMode
Ord, Int -> ExitMode -> ShowS
[ExitMode] -> ShowS
ExitMode -> String
(Int -> ExitMode -> ShowS)
-> (ExitMode -> String) -> ([ExitMode] -> ShowS) -> Show ExitMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExitMode] -> ShowS
$cshowList :: [ExitMode] -> ShowS
show :: ExitMode -> String
$cshow :: ExitMode -> String
showsPrec :: Int -> ExitMode -> ShowS
$cshowsPrec :: Int -> ExitMode -> ShowS
Show)

-- | An observation with measurements before and after running an action.
data Observation v s =
    Observation
        { Observation v s -> v
obsLabelStart :: v -- ^ Call-site information about the start of the observation
        , Observation v s -> s
obsStart      :: s -- ^ Measurement taken before running the action
        , Observation v s -> Maybe v
obsLabelEnd   :: Maybe v -- ^ Call-site information about the end of the observation
        , Observation v s -> ExitMode
obsExit       :: ExitMode -- ^ 'ExitMode' of the action.
        }

--  | An 'Observation' that doesn't have an 'obsEnd' value yet.
data PartialObservation v s =
    PartialObservation
        { PartialObservation v s -> v
obsMsg   :: v
        , PartialObservation v s -> s
obsValue :: s
        , PartialObservation v s -> Integer
obsDepth :: Integer
        }

-- | State of partial observations
data ObsState v s =
    ObsState
        { ObsState v s -> Integer
obsMaxDepth :: Integer
        , ObsState v s -> [PartialObservation v s]
obsPartials :: [PartialObservation v s]
        }

initialState :: ObsState v s
initialState :: ObsState v s
initialState = Integer -> [PartialObservation v s] -> ObsState v s
forall v s. Integer -> [PartialObservation v s] -> ObsState v s
ObsState Integer
0 []

-- see note [Logging and Tracing]
-- | Handle the 'LogObserve' effect by recording observations
--   @s@ before and after the observed action, and turning
--   them into 'LogMessage (Observation s)' values.
handleObserve ::
    forall v s effs.
    (v -> Eff effs s) -- ^ How to get the current 's'
    -> (Observation v s -> Eff effs ()) -- what to do with the observation
    -> Eff (LogObserve v ': effs)
    ~> Eff effs
handleObserve :: (v -> Eff effs s)
-> (Observation v s -> Eff effs ())
-> Eff (LogObserve v : effs) ~> Eff effs
handleObserve v -> Eff effs s
getCurrent Observation v s -> Eff effs ()
handleObs =
    Eff effs (x, ObsState v s) -> Eff effs x
forall a. Eff effs (a, ObsState v s) -> Eff effs a
handleFinalState
    (Eff effs (x, ObsState v s) -> Eff effs x)
-> (Eff (LogObserve v : effs) x -> Eff effs (x, ObsState v s))
-> Eff (LogObserve v : effs) x
-> Eff effs x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObsState v s
-> Eff (State (ObsState v s) : effs) x
-> Eff effs (x, ObsState v s)
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs (a, s)
runState @(ObsState v s) ObsState v s
forall v s. ObsState v s
initialState
    (Eff (State (ObsState v s) : effs) x -> Eff effs (x, ObsState v s))
-> (Eff (LogObserve v : effs) x
    -> Eff (State (ObsState v s) : effs) x)
-> Eff (LogObserve v : effs) x
-> Eff effs (x, ObsState v s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff (LogObserve v : State (ObsState v s) : effs) x
-> Eff (State (ObsState v s) : effs) x
Eff (LogObserve v : State (ObsState v s) : effs)
~> Eff (State (ObsState v s) : effs)
handler
    (Eff (LogObserve v : State (ObsState v s) : effs) x
 -> Eff (State (ObsState v s) : effs) x)
-> (Eff (LogObserve v : effs) x
    -> Eff (LogObserve v : State (ObsState v s) : effs) x)
-> Eff (LogObserve v : effs) x
-> Eff (State (ObsState v s) : effs) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (effs :: [* -> *]) (a :: * -> *) (b :: * -> *).
Eff (a : effs) ~> Eff (a : b : effs)
Eff (LogObserve v : effs)
~> Eff (LogObserve v : State (ObsState v s) : effs)
raiseUnder @effs @(LogObserve v) @(State (ObsState v s))
    where
        -- empty the stack of partial observations at the very end.
        handleFinalState :: forall a. Eff effs (a, ObsState v s) -> Eff effs a
        handleFinalState :: Eff effs (a, ObsState v s) -> Eff effs a
handleFinalState Eff effs (a, ObsState v s)
action = do
            (a
result, ObsState v s
finalState) <- Eff effs (a, ObsState v s)
action
            ObsState v s
_ <- Maybe v -> ObsState v s -> Integer -> Eff effs (ObsState v s)
handleObserveAfter Maybe v
forall a. Maybe a
Nothing ObsState v s
finalState Integer
0
            a -> Eff effs a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result

        -- when an action with the given depth is finished, take the final
        -- measurement and clear the stack of partial observations.
        handleObserveAfter :: Maybe v -> ObsState v s -> Integer -> Eff effs (ObsState v s)
        handleObserveAfter :: Maybe v -> ObsState v s -> Integer -> Eff effs (ObsState v s)
handleObserveAfter Maybe v
v' ObsState{[PartialObservation v s]
obsPartials :: [PartialObservation v s]
obsPartials :: forall v s. ObsState v s -> [PartialObservation v s]
obsPartials} Integer
i = do
                let ([PartialObservation v s]
finishedPartials, [PartialObservation v s]
remainingPartials) = (PartialObservation v s -> Bool)
-> [PartialObservation v s]
-> ([PartialObservation v s], [PartialObservation v s])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
(<=) Integer
i (Integer -> Bool)
-> (PartialObservation v s -> Integer)
-> PartialObservation v s
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PartialObservation v s -> Integer
forall v s. PartialObservation v s -> Integer
obsDepth) [PartialObservation v s]
obsPartials
                [PartialObservation v s]
-> (PartialObservation v s -> Eff effs ()) -> Eff effs ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [PartialObservation v s]
finishedPartials ((PartialObservation v s -> Eff effs ()) -> Eff effs ())
-> (PartialObservation v s -> Eff effs ()) -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ \PartialObservation{v
obsMsg :: v
obsMsg :: forall v s. PartialObservation v s -> v
obsMsg, s
obsValue :: s
obsValue :: forall v s. PartialObservation v s -> s
obsValue,Integer
obsDepth :: Integer
obsDepth :: forall v s. PartialObservation v s -> Integer
obsDepth} -> do
                    -- we assume that a 'PartialObservation' was completed
                    -- regularly if it is handled at its own depth level.
                    -- If the @obsDepth@ is greater than @i@ then one or more
                    -- 'LObserveAfter' calls were skipped, which we note with
                    -- 'Irregular'.
                    let exitMode :: ExitMode
exitMode = if Integer
obsDepth Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
i then ExitMode
Regular else ExitMode
Irregular
                        message :: Observation v s
message  =
                            Observation :: forall v s. v -> s -> Maybe v -> ExitMode -> Observation v s
Observation
                                { obsLabelStart :: v
obsLabelStart = v
obsMsg
                                , obsStart :: s
obsStart = s
obsValue
                                , obsExit :: ExitMode
obsExit=ExitMode
exitMode
                                , obsLabelEnd :: Maybe v
obsLabelEnd = case ExitMode
exitMode of { ExitMode
Regular -> Maybe v
v'; ExitMode
Irregular -> Maybe v
forall a. Maybe a
Nothing }
                                }
                    Observation v s -> Eff effs ()
handleObs Observation v s
message
                ObsState v s -> Eff effs (ObsState v s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ObsState :: forall v s. Integer -> [PartialObservation v s] -> ObsState v s
ObsState{obsMaxDepth :: Integer
obsMaxDepth=Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1, obsPartials :: [PartialObservation v s]
obsPartials=[PartialObservation v s]
remainingPartials}

        handleObserveBefore :: v -> ObsState v s -> Eff effs (ObsState v s, ObservationHandle)
        handleObserveBefore :: v -> ObsState v s -> Eff effs (ObsState v s, ObservationHandle)
handleObserveBefore v
v ObsState{[PartialObservation v s]
obsPartials :: [PartialObservation v s]
obsPartials :: forall v s. ObsState v s -> [PartialObservation v s]
obsPartials,Integer
obsMaxDepth :: Integer
obsMaxDepth :: forall v s. ObsState v s -> Integer
obsMaxDepth} = do
            s
current <- v -> Eff effs s
getCurrent v
v
            let newMaxDepth :: Integer
newMaxDepth = Integer
obsMaxDepth Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
                msg :: PartialObservation v s
msg = PartialObservation :: forall v s. v -> s -> Integer -> PartialObservation v s
PartialObservation
                        { obsMsg :: v
obsMsg = v
v
                        , obsValue :: s
obsValue = s
current
                        , obsDepth :: Integer
obsDepth = Integer
newMaxDepth
                        }
                newState :: ObsState v s
newState = ObsState :: forall v s. Integer -> [PartialObservation v s] -> ObsState v s
ObsState{obsMaxDepth :: Integer
obsMaxDepth=Integer
newMaxDepth,obsPartials :: [PartialObservation v s]
obsPartials=PartialObservation v s
msgPartialObservation v s
-> [PartialObservation v s] -> [PartialObservation v s]
forall a. a -> [a] -> [a]
:[PartialObservation v s]
obsPartials}
            (ObsState v s, ObservationHandle)
-> Eff effs (ObsState v s, ObservationHandle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ObsState v s
newState, Integer -> ObservationHandle
ObservationHandle Integer
newMaxDepth)

        handler ::
            Eff (LogObserve v ': State (ObsState v s) ': effs)
            ~> Eff (State (ObsState v s) ': effs)
        handler :: Eff (LogObserve v : State (ObsState v s) : effs) x
-> Eff (State (ObsState v s) : effs) x
handler = (LogObserve v ~> Eff (State (ObsState v s) : effs))
-> Eff (LogObserve v : State (ObsState v s) : effs)
   ~> Eff (State (ObsState v s) : effs)
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret ((LogObserve v ~> Eff (State (ObsState v s) : effs))
 -> Eff (LogObserve v : State (ObsState v s) : effs)
    ~> Eff (State (ObsState v s) : effs))
-> (LogObserve v ~> Eff (State (ObsState v s) : effs))
-> Eff (LogObserve v : State (ObsState v s) : effs)
   ~> Eff (State (ObsState v s) : effs)
forall a b. (a -> b) -> a -> b
$ \case
            ObserveBefore vl -> do
                ObsState v s
currentState <- forall (effs :: [* -> *]).
Member (State (ObsState v s)) effs =>
Eff effs (ObsState v s)
forall s (effs :: [* -> *]). Member (State s) effs => Eff effs s
get @(ObsState v s)
                (ObsState v s
newState, ObservationHandle
handle) <- Eff effs (ObsState v s, ObservationHandle)
-> Eff
     (State (ObsState v s) : effs) (ObsState v s, ObservationHandle)
forall (effs :: [* -> *]) a (e :: * -> *).
Eff effs a -> Eff (e : effs) a
raise (v -> ObsState v s -> Eff effs (ObsState v s, ObservationHandle)
handleObserveBefore v
vl ObsState v s
currentState)
                ObsState v s -> Eff (State (ObsState v s) : effs) ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
s -> Eff effs ()
put ObsState v s
newState
                ObservationHandle
-> Eff (State (ObsState v s) : effs) ObservationHandle
forall (f :: * -> *) a. Applicative f => a -> f a
pure ObservationHandle
handle
            ObserveAfter v' (ObservationHandle i) -> do
                ObsState v s
currentState <- forall (effs :: [* -> *]).
Member (State (ObsState v s)) effs =>
Eff effs (ObsState v s)
forall s (effs :: [* -> *]). Member (State s) effs => Eff effs s
get @(ObsState v s)
                ObsState v s
newState <- Eff effs (ObsState v s)
-> Eff (State (ObsState v s) : effs) (ObsState v s)
forall (effs :: [* -> *]) a (e :: * -> *).
Eff effs a -> Eff (e : effs) a
raise (Maybe v -> ObsState v s -> Integer -> Eff effs (ObsState v s)
handleObserveAfter Maybe v
v' ObsState v s
currentState Integer
i)
                ObsState v s -> Eff (State (ObsState v s) : effs) ()
forall s (effs :: [* -> *]).
Member (State s) effs =>
s -> Eff effs ()
put ObsState v s
newState

-- | Interpret the 'LogObserve' effect by logging a "start" message
--   before the action and an "end" message after the action.
handleObserveLog ::
    forall effs.
    Member (LogMsg Text) effs
    => Eff (LogObserve (LogMessage Text) ': effs)
    ~> Eff effs
handleObserveLog :: Eff (LogObserve (LogMessage Text) : effs) ~> Eff effs
handleObserveLog =
    (LogMessage Text -> Eff effs ())
-> (Observation (LogMessage Text) () -> Eff effs ())
-> Eff (LogObserve (LogMessage Text) : effs) ~> Eff effs
forall v s (effs :: [* -> *]).
(v -> Eff effs s)
-> (Observation v s -> Eff effs ())
-> Eff (LogObserve v : effs) ~> Eff effs
handleObserve (\LogMessage Text
_ -> () -> Eff effs ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Observation (LogMessage Text) () -> Eff effs ()
forall a (effs :: [* -> *]) s.
(Semigroup a, IsString a, FindElem (LogMsg a) effs) =>
Observation (LogMessage a) s -> Eff effs ()
handleAfter
    (Eff (LogObserve (LogMessage Text) : effs) x -> Eff effs x)
-> (Eff (LogObserve (LogMessage Text) : effs) x
    -> Eff (LogObserve (LogMessage Text) : effs) x)
-> Eff (LogObserve (LogMessage Text) : effs) x
-> Eff effs x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogObserve (LogMessage Text)
 ~> Eff (LogObserve (LogMessage Text) : effs))
-> Eff (LogObserve (LogMessage Text) : effs)
   ~> Eff (LogObserve (LogMessage Text) : effs)
forall (eff :: * -> *) (effs :: [* -> *]).
Member eff effs =>
(eff ~> Eff effs) -> Eff effs ~> Eff effs
interpose LogObserve (LogMessage Text)
~> Eff (LogObserve (LogMessage Text) : effs)
handleBefore
        where
            handleBefore :: LogObserve (LogMessage Text) ~> Eff (LogObserve (LogMessage Text) ': effs)
            handleBefore :: LogObserve (LogMessage Text) x
-> Eff (LogObserve (LogMessage Text) : effs) x
handleBefore = \case
                    ObserveBefore LogMessage Text
msg -> do
                        let msg' :: LogMessage Text
msg' = (Text -> Text) -> LogMessage Text -> LogMessage Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap  (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" start") LogMessage Text
msg
                        LogMsg Text () -> Eff (LogObserve (LogMessage Text) : effs) ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg Text () -> Eff (LogObserve (LogMessage Text) : effs) ())
-> LogMsg Text () -> Eff (LogObserve (LogMessage Text) : effs) ()
forall a b. (a -> b) -> a -> b
$ LogMessage Text -> LogMsg Text ()
forall a. LogMessage a -> LogMsg a ()
LMessage LogMessage Text
msg'
                        LogObserve (LogMessage Text) ObservationHandle
-> Eff (LogObserve (LogMessage Text) : effs) ObservationHandle
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogObserve (LogMessage Text) ObservationHandle
 -> Eff (LogObserve (LogMessage Text) : effs) ObservationHandle)
-> LogObserve (LogMessage Text) ObservationHandle
-> Eff (LogObserve (LogMessage Text) : effs) ObservationHandle
forall a b. (a -> b) -> a -> b
$ LogMessage Text -> LogObserve (LogMessage Text) ObservationHandle
forall a. a -> LogObserve a ObservationHandle
ObserveBefore LogMessage Text
msg
                    ObserveAfter Maybe (LogMessage Text)
v' ObservationHandle
i -> forall (effs :: [* -> *]) a.
Member (LogObserve (LogMessage Text)) effs =>
LogObserve (LogMessage Text) a -> Eff effs a
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send @(LogObserve (LogMessage Text)) (LogObserve (LogMessage Text) ()
 -> Eff (LogObserve (LogMessage Text) : effs) ())
-> LogObserve (LogMessage Text) ()
-> Eff (LogObserve (LogMessage Text) : effs) ()
forall a b. (a -> b) -> a -> b
$ Maybe (LogMessage Text)
-> ObservationHandle -> LogObserve (LogMessage Text) ()
forall a. Maybe a -> ObservationHandle -> LogObserve a ()
ObserveAfter Maybe (LogMessage Text)
v' ObservationHandle
i
            handleAfter :: Observation (LogMessage a) s -> Eff effs ()
handleAfter Observation{LogMessage a
obsLabelStart :: LogMessage a
obsLabelStart :: forall v s. Observation v s -> v
obsLabelStart, ExitMode
obsExit :: ExitMode
obsExit :: forall v s. Observation v s -> ExitMode
obsExit} = do
                let msg' :: LogMessage a
msg' = (a -> a) -> LogMessage a -> LogMessage a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
lbl -> case ExitMode
obsExit of { ExitMode
Regular -> a
lbl a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" end"; ExitMode
Irregular -> a
lbl a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
" end (irregular)"} ) LogMessage a
obsLabelStart
                LogMsg a () -> Eff effs ()
forall (eff :: * -> *) (effs :: [* -> *]) a.
Member eff effs =>
eff a -> Eff effs a
send (LogMsg a () -> Eff effs ()) -> LogMsg a () -> Eff effs ()
forall a b. (a -> b) -> a -> b
$ LogMessage a -> LogMsg a ()
forall a. LogMessage a -> LogMsg a ()
LMessage LogMessage a
msg'

makeEffect ''LogObserve