{-# 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
Description : Polysemy logging effect
Copyright   : (c) Adam Conner-Sax 2019
License     : BSD-3-Clause
Maintainer  : adam_conner_sax@yahoo.com
Stability   : experimental

<https://github.com/isovector/polysemy#readme Polysemy> logger effect,
using pretty-printing and severity based on <http://hackage.haskell.org/package/logging-effect logging-effect>. Adds a Prefixing effect so that it's easy to wrap entire
functions, etc. in logging prefixes and thus to distinguish where things are being logged from more easily.  Also allows filtering
by severity.
-}
module Knit.Effect.Logger
  (
    -- * Logging Types
    LogSeverity(..)
  , LogEntry(..)

  -- * Effects
  , Logger(..)
  , PrefixLog  

  -- * Actions
  , log
  , logLE
  , wrapPrefix
  , getPrefix
  , logWithPrefixToIO
  
  -- * Interpreters
  , filteredLogEntriesToIO

  -- * Subsets for filtering
  , logAll
  , logDebug
  , logDiagnostic
  , nonDiagnostic

  -- * Type Synonyms and Constraints for convenience
  , 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



-- TODO: consider a more interesting Handler type.  As in co-log (https://hackage.haskell.org/package/co-log-core)
-- where you newtype it and then can exploit its profunctoriality.
-- I got lost here.  Was trying to be compatible with logging-effect but I'm not sure why
-- the idea that the runner takes a function to handle the logging in the rest of the stack seems okay.  Though why not be more direct
-- once we are using effects in the first place?  Isn't that handler a mix of pretty-printing and interpreting and we would
-- rather separate those concerns?  So we should have an (a -> Text) and then interpreters in whatever?  I guess we merge them because
-- conversion is uneccessary if we throw a message away?  But still, the interpreters could take the pretty-printers as arguments?
-- Parking this for now, since it has absorbed outsize time for no benefit except some understanding.

-- | Severity/importance of message.
data LogSeverity =
  -- | Most detailed levels of logging.  Int argument can be used adding fine distinctions between debug levels.
  Debug Int
  -- | Minimal details about effects and what is being called. 
  | Diagnostic
  -- | Informational messages about progress of compuation or document knitting.
  | Info
  -- | Messages intended to alert the user to an issue in the computation or document production.
  | Warning
  -- | Likely unrecoverable issue in computation or document production.
  | 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)

-- NB: Cribbed from monad-logger.  Thanks ocharles!
-- TODO: add colors for ansi-terminal output
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

-- | A basic log entry with a severity and a ('Text') message
data LogEntry = LogEntry { LogEntry -> LogSeverity
severity :: LogSeverity, LogEntry -> Text
message :: T.Text }

-- | log everything.
logAll :: LogSeverity -> Bool
logAll :: LogSeverity -> Bool
logAll = Bool -> LogSeverity -> Bool
forall a b. a -> b -> a
const Bool
True
{-# INLINEABLE logAll #-}

-- | log all but 'Debug' messages.
logDiagnostic :: LogSeverity -> Bool
logDiagnostic :: LogSeverity -> Bool
logDiagnostic (Debug _) = Bool
False
logDiagnostic _         = Bool
True
{-# INLINEABLE logDiagnostic #-}

-- | log everything above 'Diagnostic'.
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 #-}

-- | log debug messages with level lower than or equal to the given @Int@.
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 #-}

-- | The Logger effect (the same as the 'Polysemy.Output' effect). 
data Logger a m r where
  Log :: a -> Logger a m ()

-- | Add one log entry of arbitrary type.  If you want to log with another type besides @LogEntry.
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 #-}

-- | Add one log-entry of the @LogEntry@ type.
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-alias for handler functions (unexported).
type Handler m msg = msg -> m ()

-- | Helper function for logging with monad-logger handler.
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 #-}

-- | Prefix Effect
data PrefixLog m r where
  AddPrefix :: T.Text -> PrefixLog m () -- ^ Represents adding a prefix to the logging output
  RemovePrefix :: PrefixLog m () -- ^ Represents removing one level of prefixing
  GetPrefix :: PrefixLog m T.Text -- ^ Represents retrieving the current prefix

-- | Add one level of prefix.
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 #-}

-- | Remove last prefix.
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 #-}

-- | Get current prefix 
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 #-}

-- | Add a prefix for the block of code.
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 #-}

-- | Interpret PrefixLog in @Polysemy.State [T.Text]@.
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 -- type application required here since tail is polymorphic
  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 #-}

-- | Interpret the 'PrefixLog' effect in State and run that.
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 #-}

-- | Monad-logger style wrapper to add prefixes to log messages.
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 }

-- | Render a prefixed log message with the pretty-printer.
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 #-}

-- | Render a prefixed log message with the pretty-printer.
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)


-- | Use @PrefixLog@ Effect to re-interpret all the logged messages to WithPrefix form.
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 #-}

-- the use of "raise" below is there since we are running the handler in the stack that still has the LogPrefix effect.
-- I couldn't figure out how to write this the other way.
-- | Given a handler for @WithPrefix a@ in the remaining effects (IO, e.g.,), run the Logger and Prefix effects and handle all the logging
-- messages via that handler.
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 #-}

-- | Add a severity filter to a handler.
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 #-}

-- | Simple handler, uses a function from message to Text and then outputs all messages in 'IO'.
-- Uses "Say" to insure messages issued from each thread are output coherently.
-- Can be used as base for any other handler that gives @Text@.
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 #-}


-- | '(a -> Text)' function for prefixedLogEntries
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 #-}

-- | log prefixed entries directly to IO
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 #-}

-- | This function can be used to log directly to IO, bypassing the effect.
-- It's here to allow logging from within functions that must be run under more
-- limited stacks and then embedded.
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 #-}

-- | A synonym for a function to handle direct logging from IO.  Used to allow logging from any stack with IO.
type LogWithPrefixIO = T.Text -> LogEntry -> IO ()

-- | Run the 'Logger' and 'PrefixLog' effects in 'IO': filtered via the severity of the message and formatted using "prettyprinter".
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 #-}

-- | List of Logger effects for a prefixed log of type @a@
type PrefixedLogEffects a = [PrefixLog, Logger a]

-- | List of Logger effects for a prefixed log of type @LogEntry@
type PrefixedLogEffectsLE = PrefixedLogEffects LogEntry

-- | Constraint helper for logging with prefixes
type LogWithPrefixes a effs = P.Members (PrefixedLogEffects a) effs --(P.Member PrefixLog effs, P.Member (Logger a) effs)

-- | Constraint helper for @LogEntry@ type with prefixes
type LogWithPrefixesLE effs = LogWithPrefixes LogEntry effs --(P.Member PrefixLog effs, P.Member (Logger a) effs)