{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module Knit.Effect.Logger
(
LogSeverity(..)
, LogEntry(..)
, Logger(..)
, PrefixLog
, log
, logLE
, wrapPrefix
, getPrefix
, logWithPrefixToIO
, filteredLogEntriesToIO
, logAll
, logDebug
, logDiagnostic
, nonDiagnostic
, PrefixedLogEffects
, PrefixedLogEffectsLE
, LogWithPrefixes
, LogWithPrefixesLE
, LogWithPrefixIO
)
where
import qualified Polysemy as P
import Polysemy.Internal ( send )
import qualified Polysemy.State as P
import Control.Monad ( when )
import Control.Monad.IO.Class ( MonadIO(..) )
import qualified Data.List as List
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Prettyprint.Doc as PP
import qualified Data.Text.Prettyprint.Doc.Render.Text
as PP
import Data.Data (Data, Typeable)
import Prelude hiding ( log )
import System.IO ( hFlush
, stdout
)
import qualified Say as S
data LogSeverity =
Debug Int
| Diagnostic
| Info
| Warning
| Error
deriving (Int -> LogSeverity -> ShowS
[LogSeverity] -> ShowS
LogSeverity -> String
(Int -> LogSeverity -> ShowS)
-> (LogSeverity -> String)
-> ([LogSeverity] -> ShowS)
-> Show LogSeverity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogSeverity] -> ShowS
$cshowList :: [LogSeverity] -> ShowS
show :: LogSeverity -> String
$cshow :: LogSeverity -> String
showsPrec :: Int -> LogSeverity -> ShowS
$cshowsPrec :: Int -> LogSeverity -> ShowS
Show, LogSeverity -> LogSeverity -> Bool
(LogSeverity -> LogSeverity -> Bool)
-> (LogSeverity -> LogSeverity -> Bool) -> Eq LogSeverity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogSeverity -> LogSeverity -> Bool
$c/= :: LogSeverity -> LogSeverity -> Bool
== :: LogSeverity -> LogSeverity -> Bool
$c== :: LogSeverity -> LogSeverity -> Bool
Eq, Eq LogSeverity
Eq LogSeverity =>
(LogSeverity -> LogSeverity -> Ordering)
-> (LogSeverity -> LogSeverity -> Bool)
-> (LogSeverity -> LogSeverity -> Bool)
-> (LogSeverity -> LogSeverity -> Bool)
-> (LogSeverity -> LogSeverity -> Bool)
-> (LogSeverity -> LogSeverity -> LogSeverity)
-> (LogSeverity -> LogSeverity -> LogSeverity)
-> Ord LogSeverity
LogSeverity -> LogSeverity -> Bool
LogSeverity -> LogSeverity -> Ordering
LogSeverity -> LogSeverity -> LogSeverity
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 :: LogSeverity -> LogSeverity -> LogSeverity
$cmin :: LogSeverity -> LogSeverity -> LogSeverity
max :: LogSeverity -> LogSeverity -> LogSeverity
$cmax :: LogSeverity -> LogSeverity -> LogSeverity
>= :: LogSeverity -> LogSeverity -> Bool
$c>= :: LogSeverity -> LogSeverity -> Bool
> :: LogSeverity -> LogSeverity -> Bool
$c> :: LogSeverity -> LogSeverity -> Bool
<= :: LogSeverity -> LogSeverity -> Bool
$c<= :: LogSeverity -> LogSeverity -> Bool
< :: LogSeverity -> LogSeverity -> Bool
$c< :: LogSeverity -> LogSeverity -> Bool
compare :: LogSeverity -> LogSeverity -> Ordering
$ccompare :: LogSeverity -> LogSeverity -> Ordering
$cp1Ord :: Eq LogSeverity
Ord, Typeable, Typeable LogSeverity
DataType
Constr
Typeable LogSeverity =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LogSeverity -> c LogSeverity)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LogSeverity)
-> (LogSeverity -> Constr)
-> (LogSeverity -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LogSeverity))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LogSeverity))
-> ((forall b. Data b => b -> b) -> LogSeverity -> LogSeverity)
-> (forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LogSeverity -> r)
-> (forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LogSeverity -> r)
-> (forall u. (forall d. Data d => d -> u) -> LogSeverity -> [u])
-> (forall u.
Int -> (forall d. Data d => d -> u) -> LogSeverity -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity)
-> Data LogSeverity
LogSeverity -> DataType
LogSeverity -> Constr
(forall b. Data b => b -> b) -> LogSeverity -> LogSeverity
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LogSeverity -> c LogSeverity
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LogSeverity
forall a.
Typeable a =>
(forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
(r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
(r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> LogSeverity -> u
forall u. (forall d. Data d => d -> u) -> LogSeverity -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LogSeverity -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LogSeverity -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LogSeverity
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LogSeverity -> c LogSeverity
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LogSeverity)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LogSeverity)
$cError :: Constr
$cWarning :: Constr
$cInfo :: Constr
$cDiagnostic :: Constr
$cDebug :: Constr
$tLogSeverity :: DataType
gmapMo :: (forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity
gmapMp :: (forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity
gmapM :: (forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> LogSeverity -> m LogSeverity
gmapQi :: Int -> (forall d. Data d => d -> u) -> LogSeverity -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> LogSeverity -> u
gmapQ :: (forall d. Data d => d -> u) -> LogSeverity -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> LogSeverity -> [u]
gmapQr :: (r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LogSeverity -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> LogSeverity -> r
gmapQl :: (r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LogSeverity -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> LogSeverity -> r
gmapT :: (forall b. Data b => b -> b) -> LogSeverity -> LogSeverity
$cgmapT :: (forall b. Data b => b -> b) -> LogSeverity -> LogSeverity
dataCast2 :: (forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LogSeverity)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c LogSeverity)
dataCast1 :: (forall d. Data d => c (t d)) -> Maybe (c LogSeverity)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c LogSeverity)
dataTypeOf :: LogSeverity -> DataType
$cdataTypeOf :: LogSeverity -> DataType
toConstr :: LogSeverity -> Constr
$ctoConstr :: LogSeverity -> Constr
gunfold :: (forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LogSeverity
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c LogSeverity
gfoldl :: (forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LogSeverity -> c LogSeverity
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> LogSeverity -> c LogSeverity
$cp1Data :: Typeable LogSeverity
Data)
instance PP.Pretty LogSeverity where
pretty :: LogSeverity -> Doc ann
pretty = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty (Text -> Doc ann)
-> (LogSeverity -> Text) -> LogSeverity -> Doc ann
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
LT.pack (String -> Text) -> (LogSeverity -> String) -> LogSeverity -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSeverity -> String
forall a. Show a => a -> String
show
data LogEntry = LogEntry { LogEntry -> LogSeverity
severity :: LogSeverity, LogEntry -> Text
message :: T.Text }
logAll :: LogSeverity -> Bool
logAll :: LogSeverity -> Bool
logAll = Bool -> LogSeverity -> Bool
forall a b. a -> b -> a
const Bool
True
{-# INLINEABLE logAll #-}
logDiagnostic :: LogSeverity -> Bool
logDiagnostic :: LogSeverity -> Bool
logDiagnostic (Debug _) = Bool
False
logDiagnostic _ = Bool
True
{-# INLINEABLE logDiagnostic #-}
nonDiagnostic :: LogSeverity -> Bool
nonDiagnostic :: LogSeverity -> Bool
nonDiagnostic ls :: LogSeverity
ls = LogSeverity
ls LogSeverity -> [LogSeverity] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [LogSeverity
Info, LogSeverity
Warning, LogSeverity
Error]
{-# INLINEABLE nonDiagnostic #-}
logDebug :: Int -> LogSeverity -> Bool
logDebug :: Int -> LogSeverity -> Bool
logDebug l :: Int
l (Debug n :: Int
n) = Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
l
logDebug _ _ = Bool
True
{-# INLINEABLE logDebug #-}
data Logger a m r where
Log :: a -> Logger a m ()
log :: P.Member (Logger a) effs => a -> P.Sem effs ()
log :: a -> Sem effs ()
log = Logger a (Sem effs) () -> Sem effs ()
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Member e r =>
e (Sem r) a -> Sem r a
send (Logger a (Sem effs) () -> Sem effs ())
-> (a -> Logger a (Sem effs) ()) -> a -> Sem effs ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Logger a (Sem effs) ()
forall k a (m :: k). a -> Logger a m ()
Log
{-# INLINEABLE log #-}
logLE
:: P.Member (Logger LogEntry) effs => LogSeverity -> T.Text -> P.Sem effs ()
logLE :: LogSeverity -> Text -> Sem effs ()
logLE ls :: LogSeverity
ls lm :: Text
lm = LogEntry -> Sem effs ()
forall a (effs :: [(* -> *) -> * -> *]).
Member (Logger a) effs =>
a -> Sem effs ()
log (LogSeverity -> Text -> LogEntry
LogEntry LogSeverity
ls Text
lm)
{-# INLINEABLE logLE #-}
type Handler m msg = msg -> m ()
logWithHandler
:: Handler (P.Sem effs) a -> P.Sem (Logger a ': effs) x -> P.Sem effs x
logWithHandler :: Handler (Sem effs) a -> Sem (Logger a : effs) x -> Sem effs x
logWithHandler handler :: Handler (Sem effs) a
handler = (forall x (m :: * -> *). Logger a m x -> Sem effs x)
-> Sem (Logger a : effs) x -> Sem effs x
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
FirstOrder e "interpret" =>
(forall x (m :: * -> *). e m x -> Sem r x)
-> Sem (e : r) a -> Sem r a
P.interpret (\(Log a) -> Handler (Sem effs) a
handler a
a)
{-# INLINEABLE logWithHandler #-}
data PrefixLog m r where
AddPrefix :: T.Text -> PrefixLog m ()
RemovePrefix :: PrefixLog m ()
GetPrefix :: PrefixLog m T.Text
addPrefix :: P.Member PrefixLog effs => T.Text -> P.Sem effs ()
addPrefix :: Text -> Sem effs ()
addPrefix = PrefixLog (Sem effs) () -> Sem effs ()
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Member e r =>
e (Sem r) a -> Sem r a
send (PrefixLog (Sem effs) () -> Sem effs ())
-> (Text -> PrefixLog (Sem effs) ()) -> Text -> Sem effs ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PrefixLog (Sem effs) ()
forall k (m :: k). Text -> PrefixLog m ()
AddPrefix
{-# INLINEABLE addPrefix #-}
removePrefix :: P.Member PrefixLog effs => P.Sem effs ()
removePrefix :: Sem effs ()
removePrefix = PrefixLog (Sem effs) () -> Sem effs ()
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Member e r =>
e (Sem r) a -> Sem r a
send PrefixLog (Sem effs) ()
forall k (m :: k). PrefixLog m ()
RemovePrefix
{-# INLINEABLE removePrefix #-}
getPrefix :: P.Member PrefixLog effs => P.Sem effs T.Text
getPrefix :: Sem effs Text
getPrefix = PrefixLog (Sem effs) Text -> Sem effs Text
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Member e r =>
e (Sem r) a -> Sem r a
send (PrefixLog (Sem effs) Text -> Sem effs Text)
-> PrefixLog (Sem effs) Text -> Sem effs Text
forall a b. (a -> b) -> a -> b
$ PrefixLog (Sem effs) Text
forall k (m :: k). PrefixLog m Text
GetPrefix
{-# INLINEABLE getPrefix #-}
wrapPrefix :: P.Member PrefixLog effs => T.Text -> P.Sem effs a -> P.Sem effs a
wrapPrefix :: Text -> Sem effs a -> Sem effs a
wrapPrefix p :: Text
p l :: Sem effs a
l = do
Text -> Sem effs ()
forall (effs :: [(* -> *) -> * -> *]).
Member PrefixLog effs =>
Text -> Sem effs ()
addPrefix Text
p
a
res <- Sem effs a
l
Sem effs ()
forall (effs :: [(* -> *) -> * -> *]).
Member PrefixLog effs =>
Sem effs ()
removePrefix
a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res
{-# INLINEABLE wrapPrefix #-}
prefixInState
:: forall effs a
. P.Sem (PrefixLog ': effs) a
-> P.Sem (P.State [T.Text] ': effs) a
prefixInState :: Sem (PrefixLog : effs) a -> Sem (State [Text] : effs) a
prefixInState = (forall (m :: * -> *) x.
PrefixLog m x -> Sem (State [Text] : effs) x)
-> Sem (PrefixLog : effs) a -> Sem (State [Text] : effs) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
(r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (m :: * -> *) x. e1 m x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpret ((forall (m :: * -> *) x.
PrefixLog m x -> Sem (State [Text] : effs) x)
-> Sem (PrefixLog : effs) a -> Sem (State [Text] : effs) a)
-> (forall (m :: * -> *) x.
PrefixLog m x -> Sem (State [Text] : effs) x)
-> Sem (PrefixLog : effs) a
-> Sem (State [Text] : effs) a
forall a b. (a -> b) -> a -> b
$ \case
AddPrefix t -> ([Text] -> [Text]) -> Sem (State [Text] : effs) ()
forall s (r :: [(* -> *) -> * -> *]).
Member (State s) r =>
(s -> s) -> Sem r ()
P.modify (Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:)
RemovePrefix -> ([Text] -> [Text]) -> Sem (State [Text] : effs) ()
forall s (r :: [(* -> *) -> * -> *]).
Member (State s) r =>
(s -> s) -> Sem r ()
P.modify @[T.Text] [Text] -> [Text]
forall a. [a] -> [a]
tail
GetPrefix -> ([Text] -> Text)
-> Sem (State [Text] : effs) [Text]
-> Sem (State [Text] : effs) Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> [Text] -> Text
T.intercalate "." ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
List.reverse) Sem (State [Text] : effs) [Text]
forall s (r :: [(* -> *) -> * -> *]).
MemberWithError (State s) r =>
Sem r s
P.get
{-# INLINEABLE prefixInState #-}
runPrefix :: P.Sem (PrefixLog ': effs) a -> P.Sem effs a
runPrefix :: Sem (PrefixLog : effs) a -> Sem effs a
runPrefix = (([Text], a) -> a) -> Sem effs ([Text], a) -> Sem effs a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text], a) -> a
forall a b. (a, b) -> b
snd (Sem effs ([Text], a) -> Sem effs a)
-> (Sem (PrefixLog : effs) a -> Sem effs ([Text], a))
-> Sem (PrefixLog : effs) a
-> Sem effs a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Sem (State [Text] : effs) a -> Sem effs ([Text], a)
forall s (r :: [(* -> *) -> * -> *]) a.
s -> Sem (State s : r) a -> Sem r (s, a)
P.runState [] (Sem (State [Text] : effs) a -> Sem effs ([Text], a))
-> (Sem (PrefixLog : effs) a -> Sem (State [Text] : effs) a)
-> Sem (PrefixLog : effs) a
-> Sem effs ([Text], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (PrefixLog : effs) a -> Sem (State [Text] : effs) a
forall (effs :: [(* -> *) -> * -> *]) a.
Sem (PrefixLog : effs) a -> Sem (State [Text] : effs) a
prefixInState
{-# INLINEABLE runPrefix #-}
data WithPrefix a = WithPrefix { WithPrefix a -> Text
msgPrefix :: T.Text, WithPrefix a -> a
discardPrefix :: a }
data WithSeverity a = WithSeverity { WithSeverity a -> LogSeverity
msgSeverity :: LogSeverity, WithSeverity a -> a
discardSeverity :: a }
renderWithPrefix :: (a -> PP.Doc ann) -> WithPrefix a -> PP.Doc ann
renderWithPrefix :: (a -> Doc ann) -> WithPrefix a -> Doc ann
renderWithPrefix k :: a -> Doc ann
k (WithPrefix pr :: Text
pr a :: a
a) = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty Text
pr Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.align (a -> Doc ann
k a
a)
{-# INLINEABLE renderWithPrefix #-}
renderLogEntry
:: (T.Text -> PP.Doc ann) -> (LogEntry -> PP.Doc ann)
renderLogEntry :: (Text -> Doc ann) -> LogEntry -> Doc ann
renderLogEntry k :: Text -> Doc ann
k (LogEntry s :: LogSeverity
s t :: Text
t) =
Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.brackets (LogSeverity -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty LogSeverity
s) Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
PP.<+> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann
PP.align (Text -> Doc ann
k Text
t)
logPrefixed
:: P.Member PrefixLog effs
=> P.Sem (Logger a ': effs) x
-> P.Sem (Logger (WithPrefix a) ': effs) x
logPrefixed :: Sem (Logger a : effs) x -> Sem (Logger (WithPrefix a) : effs) x
logPrefixed =
(forall (m :: * -> *) x.
Logger a m x -> Sem (Logger (WithPrefix a) : effs) x)
-> Sem (Logger a : effs) x -> Sem (Logger (WithPrefix a) : effs) x
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
(r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (m :: * -> *) x. e1 m x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpret (\(Log a) -> Sem (Logger (WithPrefix a) : effs) Text
forall (effs :: [(* -> *) -> * -> *]).
Member PrefixLog effs =>
Sem effs Text
getPrefix Sem (Logger (WithPrefix a) : effs) Text
-> (Text -> Sem (Logger (WithPrefix a) : effs) ())
-> Sem (Logger (WithPrefix a) : effs) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\p :: Text
p -> WithPrefix a -> Sem (Logger (WithPrefix a) : effs) ()
forall a (effs :: [(* -> *) -> * -> *]).
Member (Logger a) effs =>
a -> Sem effs ()
log (Text -> a -> WithPrefix a
forall a. Text -> a -> WithPrefix a
WithPrefix Text
p a
a)))
{-# INLINEABLE logPrefixed #-}
logAndHandlePrefixed
:: forall effs a x
. Handler (P.Sem effs) (WithPrefix a)
-> P.Sem (Logger a ': (PrefixLog ': effs)) x
-> P.Sem effs x
logAndHandlePrefixed :: Handler (Sem effs) (WithPrefix a)
-> Sem (Logger a : PrefixLog : effs) x -> Sem effs x
logAndHandlePrefixed handler :: Handler (Sem effs) (WithPrefix a)
handler =
Sem (PrefixLog : effs) x -> Sem effs x
forall (effs :: [(* -> *) -> * -> *]) a.
Sem (PrefixLog : effs) a -> Sem effs a
runPrefix
(Sem (PrefixLog : effs) x -> Sem effs x)
-> (Sem (Logger a : PrefixLog : effs) x
-> Sem (PrefixLog : effs) x)
-> Sem (Logger a : PrefixLog : effs) x
-> Sem effs x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler (Sem (PrefixLog : effs)) (WithPrefix a)
-> Sem (Logger (WithPrefix a) : PrefixLog : effs) x
-> Sem (PrefixLog : effs) x
forall (effs :: [(* -> *) -> * -> *]) a x.
Handler (Sem effs) a -> Sem (Logger a : effs) x -> Sem effs x
logWithHandler (Sem effs () -> Sem (PrefixLog : effs) ()
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *]) a.
Sem r a -> Sem (e : r) a
P.raise (Sem effs () -> Sem (PrefixLog : effs) ())
-> Handler (Sem effs) (WithPrefix a)
-> Handler (Sem (PrefixLog : effs)) (WithPrefix a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handler (Sem effs) (WithPrefix a)
handler)
(Sem (Logger (WithPrefix a) : PrefixLog : effs) x
-> Sem (PrefixLog : effs) x)
-> (Sem (Logger a : PrefixLog : effs) x
-> Sem (Logger (WithPrefix a) : PrefixLog : effs) x)
-> Sem (Logger a : PrefixLog : effs) x
-> Sem (PrefixLog : effs) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (effs :: [(* -> *) -> * -> *]) a x.
Member PrefixLog effs =>
Sem (Logger a : effs) x -> Sem (Logger (WithPrefix a) : effs) x
forall a x.
Member PrefixLog (PrefixLog : effs) =>
Sem (Logger a : PrefixLog : effs) x
-> Sem (Logger (WithPrefix a) : PrefixLog : effs) x
logPrefixed @(PrefixLog ': effs)
{-# INLINEABLE logAndHandlePrefixed #-}
filterLog :: Monad m => (a -> Bool) -> Handler m a -> Handler m a
filterLog :: (a -> Bool) -> Handler m a -> Handler m a
filterLog filterF :: a -> Bool
filterF h :: Handler m a
h a :: a
a = Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (a -> Bool
filterF a
a) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Handler m a
h a
a
{-# INLINEABLE filterLog #-}
logToIO :: MonadIO m => (a -> T.Text) -> Handler m a
logToIO :: (a -> Text) -> Handler m a
logToIO toText :: a -> Text
toText a :: 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
$ do
Text -> IO ()
forall (m :: * -> *). MonadIO m => Text -> m ()
S.say (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ a -> Text
toText a
a
Handle -> IO ()
hFlush Handle
stdout
{-# INLINEABLE logToIO #-}
prefixedLogEntryToText :: WithPrefix LogEntry -> T.Text
prefixedLogEntryToText :: WithPrefix LogEntry -> Text
prefixedLogEntryToText =
(SimpleDocStream Any -> Text
forall ann. SimpleDocStream ann -> Text
PP.renderStrict (SimpleDocStream Any -> Text)
-> (WithPrefix LogEntry -> SimpleDocStream Any)
-> WithPrefix LogEntry
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty LayoutOptions
PP.defaultLayoutOptions (Doc Any -> SimpleDocStream Any)
-> (WithPrefix LogEntry -> Doc Any)
-> WithPrefix LogEntry
-> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEntry -> Doc Any) -> WithPrefix LogEntry -> Doc Any
forall a ann. (a -> Doc ann) -> WithPrefix a -> Doc ann
renderWithPrefix
((Text -> Doc Any) -> LogEntry -> Doc Any
forall ann. (Text -> Doc ann) -> LogEntry -> Doc ann
renderLogEntry Text -> Doc Any
forall a ann. Pretty a => a -> Doc ann
PP.pretty)
)
{-# INLINEABLE prefixedLogEntryToText #-}
prefixedLogEntryToIO :: MonadIO m => Handler m (WithPrefix LogEntry)
prefixedLogEntryToIO :: Handler m (WithPrefix LogEntry)
prefixedLogEntryToIO = (WithPrefix LogEntry -> Text) -> Handler m (WithPrefix LogEntry)
forall (m :: * -> *) a. MonadIO m => (a -> Text) -> Handler m a
logToIO WithPrefix LogEntry -> Text
prefixedLogEntryToText
{-# INLINEABLE prefixedLogEntryToIO #-}
logWithPrefixToIO :: LogWithPrefixIO
logWithPrefixToIO :: LogWithPrefixIO
logWithPrefixToIO prefix :: Text
prefix le :: LogEntry
le = let wp :: WithPrefix LogEntry
wp = Text -> LogEntry -> WithPrefix LogEntry
forall a. Text -> a -> WithPrefix a
WithPrefix Text
prefix LogEntry
le in Handler IO (WithPrefix LogEntry)
forall (m :: * -> *). MonadIO m => Handler m (WithPrefix LogEntry)
prefixedLogEntryToIO WithPrefix LogEntry
wp
{-# INLINEABLE logWithPrefixToIO #-}
type LogWithPrefixIO = T.Text -> LogEntry -> IO ()
filteredLogEntriesToIO
:: MonadIO (P.Sem r)
=> (LogSeverity -> Bool)
-> P.Sem (Logger LogEntry ': (PrefixLog ': r)) x
-> P.Sem r x
filteredLogEntriesToIO :: (LogSeverity -> Bool)
-> Sem (Logger LogEntry : PrefixLog : r) x -> Sem r x
filteredLogEntriesToIO lsF :: LogSeverity -> Bool
lsF mx :: Sem (Logger LogEntry : PrefixLog : r) x
mx = do
let f :: WithPrefix LogEntry -> Bool
f a :: WithPrefix LogEntry
a = LogSeverity -> Bool
lsF (LogEntry -> LogSeverity
severity (LogEntry -> LogSeverity) -> LogEntry -> LogSeverity
forall a b. (a -> b) -> a -> b
$ WithPrefix LogEntry -> LogEntry
forall a. WithPrefix a -> a
discardPrefix WithPrefix LogEntry
a)
Handler (Sem r) (WithPrefix LogEntry)
-> Sem (Logger LogEntry : PrefixLog : r) x -> Sem r x
forall (effs :: [(* -> *) -> * -> *]) a x.
Handler (Sem effs) (WithPrefix a)
-> Sem (Logger a : PrefixLog : effs) x -> Sem effs x
logAndHandlePrefixed ((WithPrefix LogEntry -> Bool)
-> Handler (Sem r) (WithPrefix LogEntry)
-> Handler (Sem r) (WithPrefix LogEntry)
forall (m :: * -> *) a.
Monad m =>
(a -> Bool) -> Handler m a -> Handler m a
filterLog WithPrefix LogEntry -> Bool
f (Handler (Sem r) (WithPrefix LogEntry)
-> Handler (Sem r) (WithPrefix LogEntry))
-> Handler (Sem r) (WithPrefix LogEntry)
-> Handler (Sem r) (WithPrefix LogEntry)
forall a b. (a -> b) -> a -> b
$ Handler (Sem r) (WithPrefix LogEntry)
forall (m :: * -> *). MonadIO m => Handler m (WithPrefix LogEntry)
prefixedLogEntryToIO) Sem (Logger LogEntry : PrefixLog : r) x
mx
{-# INLINEABLE filteredLogEntriesToIO #-}
type PrefixedLogEffects a = [PrefixLog, Logger a]
type PrefixedLogEffectsLE = PrefixedLogEffects LogEntry
type LogWithPrefixes a effs = P.Members (PrefixedLogEffects a) effs
type LogWithPrefixesLE effs = LogWithPrefixes LogEntry effs