{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE UndecidableInstances       #-}
#if MIN_VERSION_base(4, 9, 0)
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif
-- | This module is not meant to be imported directly and may contain
-- internal mechanisms that will change without notice.
module Katip.Core where

-------------------------------------------------------------------------------
import           Control.Applicative               as A
import           Control.AutoUpdate
import           Control.Concurrent
import qualified Control.Concurrent.Async          as Async
import           Control.Concurrent.STM
import qualified Control.Concurrent.STM.TBQueue    as BQ
import           Control.Exception.Safe
import           Control.Monad                     (unless, void, when)
import           Control.Monad.Base
#if MIN_VERSION_base(4, 9, 0)
import qualified Control.Monad.Fail                as MF
#endif
import           Control.Monad.IO.Class
import           Control.Monad.IO.Unlift
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Control
#if !MIN_VERSION_either(4, 5, 0)
import           Control.Monad.Trans.Either
#endif
import           Control.Monad.Trans.Except
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.Reader
import           Control.Monad.Trans.Resource      (MonadResource, ResourceT,
                                                    transResourceT)
import           Control.Monad.Trans.RWS.Lazy      (RWST, mapRWST)
import qualified Control.Monad.Trans.RWS.Strict    as Strict (RWST, mapRWST)
import           Control.Monad.Trans.State.Lazy    (StateT, mapStateT)
import qualified Control.Monad.Trans.State.Strict  as Strict (StateT, mapStateT)
import           Control.Monad.Trans.Writer.Lazy   (WriterT, mapWriterT)
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT,
                                                              mapWriterT)
import           Data.Aeson                        (FromJSON (..), ToJSON (..),
                                                    object)
import qualified Data.Aeson                        as A
#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.Key                    as K
import qualified Data.Aeson.KeyMap                 as KM
import           Data.Bifunctor                    (Bifunctor (..))
#endif
import           Data.Foldable                     as FT
#if !MIN_VERSION_aeson(2, 0, 0)
import qualified Data.HashMap.Strict               as HM
#endif
import           Data.List
import qualified Data.Map.Strict                   as M
import           Data.Maybe                        (fromMaybe)
import           Data.Semigroup                    as SG
import qualified Data.Set                          as Set
import           Data.String
import           Data.String.Conv
import           Data.Text                         (Text)
import qualified Data.Text                         as T
import qualified Data.Text.Lazy.Builder            as B
import           Data.Time
import           GHC.Generics                      hiding (to)
#if MIN_VERSION_base(4, 8, 0)
#if !MIN_VERSION_base(4, 9, 0)
import           GHC.SrcLoc
#endif
import           GHC.Stack
#endif
import           Language.Haskell.TH
import qualified Language.Haskell.TH.Syntax        as TH
import           Lens.Micro
import           Lens.Micro.TH
import           Network.HostName
#if mingw32_HOST_OS
import           Katip.Compat
#else
import           System.Posix
#endif

-------------------------------------------------------------------------------


readMay :: Read a => String -> Maybe a
readMay :: forall a. Read a => String -> Maybe a
readMay String
s = case [a
x | (a
x,String
t) <- forall a. Read a => ReadS a
reads String
s, (String
"",String
"") <- ReadS String
lex String
t] of
              [a
x] -> forall a. a -> Maybe a
Just a
x
              []  -> forall a. Maybe a
Nothing -- no parse
              [a]
_   -> forall a. Maybe a
Nothing -- Ambiguous parse


-------------------------------------------------------------------------------
-- | Represents a heirarchy of namespaces going from general to
-- specific. For instance: ["processname", "subsystem"]. Note that
-- single-segment namespaces can be created using
-- IsString/OverloadedStrings, so "foo" will result in Namespace
-- ["foo"].
newtype Namespace = Namespace { Namespace -> [Text]
unNamespace :: [Text] }
  deriving (Namespace -> Namespace -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Namespace -> Namespace -> Bool
$c/= :: Namespace -> Namespace -> Bool
== :: Namespace -> Namespace -> Bool
$c== :: Namespace -> Namespace -> Bool
Eq,Int -> Namespace -> ShowS
[Namespace] -> ShowS
Namespace -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Namespace] -> ShowS
$cshowList :: [Namespace] -> ShowS
show :: Namespace -> String
$cshow :: Namespace -> String
showsPrec :: Int -> Namespace -> ShowS
$cshowsPrec :: Int -> Namespace -> ShowS
Show,ReadPrec [Namespace]
ReadPrec Namespace
Int -> ReadS Namespace
ReadS [Namespace]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Namespace]
$creadListPrec :: ReadPrec [Namespace]
readPrec :: ReadPrec Namespace
$creadPrec :: ReadPrec Namespace
readList :: ReadS [Namespace]
$creadList :: ReadS [Namespace]
readsPrec :: Int -> ReadS Namespace
$creadsPrec :: Int -> ReadS Namespace
Read,Eq Namespace
Namespace -> Namespace -> Bool
Namespace -> Namespace -> Ordering
Namespace -> Namespace -> Namespace
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 :: Namespace -> Namespace -> Namespace
$cmin :: Namespace -> Namespace -> Namespace
max :: Namespace -> Namespace -> Namespace
$cmax :: Namespace -> Namespace -> Namespace
>= :: Namespace -> Namespace -> Bool
$c>= :: Namespace -> Namespace -> Bool
> :: Namespace -> Namespace -> Bool
$c> :: Namespace -> Namespace -> Bool
<= :: Namespace -> Namespace -> Bool
$c<= :: Namespace -> Namespace -> Bool
< :: Namespace -> Namespace -> Bool
$c< :: Namespace -> Namespace -> Bool
compare :: Namespace -> Namespace -> Ordering
$ccompare :: Namespace -> Namespace -> Ordering
Ord,forall x. Rep Namespace x -> Namespace
forall x. Namespace -> Rep Namespace x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Namespace x -> Namespace
$cfrom :: forall x. Namespace -> Rep Namespace x
Generic,[Namespace] -> Encoding
[Namespace] -> Value
Namespace -> Bool
Namespace -> Encoding
Namespace -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: Namespace -> Bool
$comitField :: Namespace -> Bool
toEncodingList :: [Namespace] -> Encoding
$ctoEncodingList :: [Namespace] -> Encoding
toJSONList :: [Namespace] -> Value
$ctoJSONList :: [Namespace] -> Value
toEncoding :: Namespace -> Encoding
$ctoEncoding :: Namespace -> Encoding
toJSON :: Namespace -> Value
$ctoJSON :: Namespace -> Value
ToJSON,Maybe Namespace
Value -> Parser [Namespace]
Value -> Parser Namespace
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe Namespace
$comittedField :: Maybe Namespace
parseJSONList :: Value -> Parser [Namespace]
$cparseJSONList :: Value -> Parser [Namespace]
parseJSON :: Value -> Parser Namespace
$cparseJSON :: Value -> Parser Namespace
FromJSON,NonEmpty Namespace -> Namespace
Namespace -> Namespace -> Namespace
forall b. Integral b => b -> Namespace -> Namespace
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Namespace -> Namespace
$cstimes :: forall b. Integral b => b -> Namespace -> Namespace
sconcat :: NonEmpty Namespace -> Namespace
$csconcat :: NonEmpty Namespace -> Namespace
<> :: Namespace -> Namespace -> Namespace
$c<> :: Namespace -> Namespace -> Namespace
SG.Semigroup,Semigroup Namespace
Namespace
[Namespace] -> Namespace
Namespace -> Namespace -> Namespace
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Namespace] -> Namespace
$cmconcat :: [Namespace] -> Namespace
mappend :: Namespace -> Namespace -> Namespace
$cmappend :: Namespace -> Namespace -> Namespace
mempty :: Namespace
$cmempty :: Namespace
Monoid,forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Namespace -> m Exp
forall (m :: * -> *). Quote m => Namespace -> Code m Namespace
liftTyped :: forall (m :: * -> *). Quote m => Namespace -> Code m Namespace
$cliftTyped :: forall (m :: * -> *). Quote m => Namespace -> Code m Namespace
lift :: forall (m :: * -> *). Quote m => Namespace -> m Exp
$clift :: forall (m :: * -> *). Quote m => Namespace -> m Exp
TH.Lift)

instance IsString Namespace where
    fromString :: String -> Namespace
fromString String
s = [Text] -> Namespace
Namespace [forall a. IsString a => String -> a
fromString String
s]


-------------------------------------------------------------------------------
-- | Ready namespace for emission with dots to join the segments.
intercalateNs :: Namespace -> [Text]
intercalateNs :: Namespace -> [Text]
intercalateNs (Namespace [Text]
xs) = forall a. a -> [a] -> [a]
intersperse Text
"." [Text]
xs


-------------------------------------------------------------------------------
-- | Application environment, like @prod@, @devel@, @testing@.
newtype Environment = Environment { Environment -> Text
getEnvironment :: Text }
  deriving (Environment -> Environment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Environment -> Environment -> Bool
$c/= :: Environment -> Environment -> Bool
== :: Environment -> Environment -> Bool
$c== :: Environment -> Environment -> Bool
Eq,Int -> Environment -> ShowS
[Environment] -> ShowS
Environment -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Environment] -> ShowS
$cshowList :: [Environment] -> ShowS
show :: Environment -> String
$cshow :: Environment -> String
showsPrec :: Int -> Environment -> ShowS
$cshowsPrec :: Int -> Environment -> ShowS
Show,ReadPrec [Environment]
ReadPrec Environment
Int -> ReadS Environment
ReadS [Environment]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Environment]
$creadListPrec :: ReadPrec [Environment]
readPrec :: ReadPrec Environment
$creadPrec :: ReadPrec Environment
readList :: ReadS [Environment]
$creadList :: ReadS [Environment]
readsPrec :: Int -> ReadS Environment
$creadsPrec :: Int -> ReadS Environment
Read,Eq Environment
Environment -> Environment -> Bool
Environment -> Environment -> Ordering
Environment -> Environment -> Environment
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 :: Environment -> Environment -> Environment
$cmin :: Environment -> Environment -> Environment
max :: Environment -> Environment -> Environment
$cmax :: Environment -> Environment -> Environment
>= :: Environment -> Environment -> Bool
$c>= :: Environment -> Environment -> Bool
> :: Environment -> Environment -> Bool
$c> :: Environment -> Environment -> Bool
<= :: Environment -> Environment -> Bool
$c<= :: Environment -> Environment -> Bool
< :: Environment -> Environment -> Bool
$c< :: Environment -> Environment -> Bool
compare :: Environment -> Environment -> Ordering
$ccompare :: Environment -> Environment -> Ordering
Ord,forall x. Rep Environment x -> Environment
forall x. Environment -> Rep Environment x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Environment x -> Environment
$cfrom :: forall x. Environment -> Rep Environment x
Generic,[Environment] -> Encoding
[Environment] -> Value
Environment -> Bool
Environment -> Encoding
Environment -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: Environment -> Bool
$comitField :: Environment -> Bool
toEncodingList :: [Environment] -> Encoding
$ctoEncodingList :: [Environment] -> Encoding
toJSONList :: [Environment] -> Value
$ctoJSONList :: [Environment] -> Value
toEncoding :: Environment -> Encoding
$ctoEncoding :: Environment -> Encoding
toJSON :: Environment -> Value
$ctoJSON :: Environment -> Value
ToJSON,Maybe Environment
Value -> Parser [Environment]
Value -> Parser Environment
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe Environment
$comittedField :: Maybe Environment
parseJSONList :: Value -> Parser [Environment]
$cparseJSONList :: Value -> Parser [Environment]
parseJSON :: Value -> Parser Environment
$cparseJSON :: Value -> Parser Environment
FromJSON,String -> Environment
forall a. (String -> a) -> IsString a
fromString :: String -> Environment
$cfromString :: String -> Environment
IsString)


-------------------------------------------------------------------------------
data Severity
    = DebugS                   -- ^ Debug messages
    | InfoS                    -- ^ Information
    | NoticeS                  -- ^ Normal runtime Conditions
    | WarningS                 -- ^ General Warnings
    | ErrorS                   -- ^ General Errors
    | CriticalS                -- ^ Severe situations
    | AlertS                   -- ^ Take immediate action
    | EmergencyS               -- ^ System is unusable
  deriving (Severity -> Severity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Severity -> Severity -> Bool
$c/= :: Severity -> Severity -> Bool
== :: Severity -> Severity -> Bool
$c== :: Severity -> Severity -> Bool
Eq, Eq Severity
Severity -> Severity -> Bool
Severity -> Severity -> Ordering
Severity -> Severity -> Severity
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 :: Severity -> Severity -> Severity
$cmin :: Severity -> Severity -> Severity
max :: Severity -> Severity -> Severity
$cmax :: Severity -> Severity -> Severity
>= :: Severity -> Severity -> Bool
$c>= :: Severity -> Severity -> Bool
> :: Severity -> Severity -> Bool
$c> :: Severity -> Severity -> Bool
<= :: Severity -> Severity -> Bool
$c<= :: Severity -> Severity -> Bool
< :: Severity -> Severity -> Bool
$c< :: Severity -> Severity -> Bool
compare :: Severity -> Severity -> Ordering
$ccompare :: Severity -> Severity -> Ordering
Ord, Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Severity] -> ShowS
$cshowList :: [Severity] -> ShowS
show :: Severity -> String
$cshow :: Severity -> String
showsPrec :: Int -> Severity -> ShowS
$cshowsPrec :: Int -> Severity -> ShowS
Show, ReadPrec [Severity]
ReadPrec Severity
Int -> ReadS Severity
ReadS [Severity]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Severity]
$creadListPrec :: ReadPrec [Severity]
readPrec :: ReadPrec Severity
$creadPrec :: ReadPrec Severity
readList :: ReadS [Severity]
$creadList :: ReadS [Severity]
readsPrec :: Int -> ReadS Severity
$creadsPrec :: Int -> ReadS Severity
Read, forall x. Rep Severity x -> Severity
forall x. Severity -> Rep Severity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Severity x -> Severity
$cfrom :: forall x. Severity -> Rep Severity x
Generic, Int -> Severity
Severity -> Int
Severity -> [Severity]
Severity -> Severity
Severity -> Severity -> [Severity]
Severity -> Severity -> Severity -> [Severity]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Severity -> Severity -> Severity -> [Severity]
$cenumFromThenTo :: Severity -> Severity -> Severity -> [Severity]
enumFromTo :: Severity -> Severity -> [Severity]
$cenumFromTo :: Severity -> Severity -> [Severity]
enumFromThen :: Severity -> Severity -> [Severity]
$cenumFromThen :: Severity -> Severity -> [Severity]
enumFrom :: Severity -> [Severity]
$cenumFrom :: Severity -> [Severity]
fromEnum :: Severity -> Int
$cfromEnum :: Severity -> Int
toEnum :: Int -> Severity
$ctoEnum :: Int -> Severity
pred :: Severity -> Severity
$cpred :: Severity -> Severity
succ :: Severity -> Severity
$csucc :: Severity -> Severity
Enum, Severity
forall a. a -> a -> Bounded a
maxBound :: Severity
$cmaxBound :: Severity
minBound :: Severity
$cminBound :: Severity
Bounded, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Severity -> m Exp
forall (m :: * -> *). Quote m => Severity -> Code m Severity
liftTyped :: forall (m :: * -> *). Quote m => Severity -> Code m Severity
$cliftTyped :: forall (m :: * -> *). Quote m => Severity -> Code m Severity
lift :: forall (m :: * -> *). Quote m => Severity -> m Exp
$clift :: forall (m :: * -> *). Quote m => Severity -> m Exp
TH.Lift)


-------------------------------------------------------------------------------
-- | Verbosity controls the amount of information (columns) a 'Scribe'
-- emits during logging.
--
-- The convention is:
-- - 'V0' implies no additional payload information is included in message.
-- - 'V3' implies the maximum amount of payload information.
-- - Anything in between is left to the discretion of the developer.
data Verbosity = V0 | V1 | V2 | V3
  deriving (Verbosity -> Verbosity -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
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 :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
Ord, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Verbosity] -> ShowS
$cshowList :: [Verbosity] -> ShowS
show :: Verbosity -> String
$cshow :: Verbosity -> String
showsPrec :: Int -> Verbosity -> ShowS
$cshowsPrec :: Int -> Verbosity -> ShowS
Show, ReadPrec [Verbosity]
ReadPrec Verbosity
Int -> ReadS Verbosity
ReadS [Verbosity]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Verbosity]
$creadListPrec :: ReadPrec [Verbosity]
readPrec :: ReadPrec Verbosity
$creadPrec :: ReadPrec Verbosity
readList :: ReadS [Verbosity]
$creadList :: ReadS [Verbosity]
readsPrec :: Int -> ReadS Verbosity
$creadsPrec :: Int -> ReadS Verbosity
Read, forall x. Rep Verbosity x -> Verbosity
forall x. Verbosity -> Rep Verbosity x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Verbosity x -> Verbosity
$cfrom :: forall x. Verbosity -> Rep Verbosity x
Generic, Int -> Verbosity
Verbosity -> Int
Verbosity -> [Verbosity]
Verbosity -> Verbosity
Verbosity -> Verbosity -> [Verbosity]
Verbosity -> Verbosity -> Verbosity -> [Verbosity]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
$cenumFromThenTo :: Verbosity -> Verbosity -> Verbosity -> [Verbosity]
enumFromTo :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromTo :: Verbosity -> Verbosity -> [Verbosity]
enumFromThen :: Verbosity -> Verbosity -> [Verbosity]
$cenumFromThen :: Verbosity -> Verbosity -> [Verbosity]
enumFrom :: Verbosity -> [Verbosity]
$cenumFrom :: Verbosity -> [Verbosity]
fromEnum :: Verbosity -> Int
$cfromEnum :: Verbosity -> Int
toEnum :: Int -> Verbosity
$ctoEnum :: Int -> Verbosity
pred :: Verbosity -> Verbosity
$cpred :: Verbosity -> Verbosity
succ :: Verbosity -> Verbosity
$csucc :: Verbosity -> Verbosity
Enum, Verbosity
forall a. a -> a -> Bounded a
maxBound :: Verbosity
$cmaxBound :: Verbosity
minBound :: Verbosity
$cminBound :: Verbosity
Bounded, forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => Verbosity -> m Exp
forall (m :: * -> *). Quote m => Verbosity -> Code m Verbosity
liftTyped :: forall (m :: * -> *). Quote m => Verbosity -> Code m Verbosity
$cliftTyped :: forall (m :: * -> *). Quote m => Verbosity -> Code m Verbosity
lift :: forall (m :: * -> *). Quote m => Verbosity -> m Exp
$clift :: forall (m :: * -> *). Quote m => Verbosity -> m Exp
TH.Lift)


-------------------------------------------------------------------------------
renderSeverity :: Severity -> Text
renderSeverity :: Severity -> Text
renderSeverity Severity
s = case Severity
s of
      Severity
DebugS     -> Text
"Debug"
      Severity
InfoS      -> Text
"Info"
      Severity
NoticeS    -> Text
"Notice"
      Severity
WarningS   -> Text
"Warning"
      Severity
ErrorS     -> Text
"Error"
      Severity
CriticalS  -> Text
"Critical"
      Severity
AlertS     -> Text
"Alert"
      Severity
EmergencyS -> Text
"Emergency"


-------------------------------------------------------------------------------
textToSeverity :: Text -> Maybe Severity
textToSeverity :: Text -> Maybe Severity
textToSeverity = forall {a}. (Eq a, IsString a) => a -> Maybe Severity
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower
  where
    go :: a -> Maybe Severity
go a
"debug"     = forall a. a -> Maybe a
Just Severity
DebugS
    go a
"info"      = forall a. a -> Maybe a
Just Severity
InfoS
    go a
"notice"    = forall a. a -> Maybe a
Just Severity
NoticeS
    go a
"warning"   = forall a. a -> Maybe a
Just Severity
WarningS
    go a
"error"     = forall a. a -> Maybe a
Just Severity
ErrorS
    go a
"critical"  = forall a. a -> Maybe a
Just Severity
CriticalS
    go a
"alert"     = forall a. a -> Maybe a
Just Severity
AlertS
    go a
"emergency" = forall a. a -> Maybe a
Just Severity
EmergencyS
    go a
_           = forall a. Maybe a
Nothing


instance ToJSON Severity where
    toJSON :: Severity -> Value
toJSON Severity
s = Text -> Value
A.String (Severity -> Text
renderSeverity Severity
s)

instance FromJSON Severity where
    parseJSON :: Value -> Parser Severity
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"Severity" forall {m :: * -> *}. MonadFail m => Text -> m Severity
parseSeverity
      where
        parseSeverity :: Text -> m Severity
parseSeverity Text
t = case Text -> Maybe Severity
textToSeverity Text
t of
          Just Severity
x  -> forall (m :: * -> *) a. Monad m => a -> m a
return Severity
x
          Maybe Severity
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid Severity " forall a. [a] -> [a] -> [a]
++ forall a b. StringConv a b => a -> b
toS Text
t

instance ToJSON Verbosity where
    toJSON :: Verbosity -> Value
toJSON Verbosity
s = Text -> Value
A.String forall a b. (a -> b) -> a -> b
$ case Verbosity
s of
      Verbosity
V0 -> Text
"V0"
      Verbosity
V1 -> Text
"V1"
      Verbosity
V2 -> Text
"V2"
      Verbosity
V3 -> Text
"V3"

instance FromJSON Verbosity where
    parseJSON :: Value -> Parser Verbosity
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"Verbosity" forall a b. (a -> b) -> a -> b
$ \Text
s -> case Text
s of
      Text
"V0" -> forall (m :: * -> *) a. Monad m => a -> m a
return Verbosity
V0
      Text
"V1" -> forall (m :: * -> *) a. Monad m => a -> m a
return Verbosity
V1
      Text
"V2" -> forall (m :: * -> *) a. Monad m => a -> m a
return Verbosity
V2
      Text
"V3" -> forall (m :: * -> *) a. Monad m => a -> m a
return Verbosity
V3
      Text
_    -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid Verbosity " forall a. [a] -> [a] -> [a]
++ forall a b. StringConv a b => a -> b
toS Text
s


-------------------------------------------------------------------------------
-- | Log message with Builder underneath; use '<>' to concat in O(1).
newtype LogStr = LogStr { LogStr -> Builder
unLogStr :: B.Builder }
    deriving (forall x. Rep LogStr x -> LogStr
forall x. LogStr -> Rep LogStr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LogStr x -> LogStr
$cfrom :: forall x. LogStr -> Rep LogStr x
Generic, Int -> LogStr -> ShowS
[LogStr] -> ShowS
LogStr -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogStr] -> ShowS
$cshowList :: [LogStr] -> ShowS
show :: LogStr -> String
$cshow :: LogStr -> String
showsPrec :: Int -> LogStr -> ShowS
$cshowsPrec :: Int -> LogStr -> ShowS
Show, LogStr -> LogStr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogStr -> LogStr -> Bool
$c/= :: LogStr -> LogStr -> Bool
== :: LogStr -> LogStr -> Bool
$c== :: LogStr -> LogStr -> Bool
Eq)

instance IsString LogStr where
    fromString :: String -> LogStr
fromString = Builder -> LogStr
LogStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Builder
B.fromString


instance Semigroup LogStr where
  (LogStr Builder
a) <> :: LogStr -> LogStr -> LogStr
<> (LogStr Builder
b) = Builder -> LogStr
LogStr (Builder
a forall a. Semigroup a => a -> a -> a
<> Builder
b)


instance Monoid LogStr where
    mappend :: LogStr -> LogStr -> LogStr
mappend = forall a. Semigroup a => a -> a -> a
(<>)
    mempty :: LogStr
mempty = Builder -> LogStr
LogStr forall a. Monoid a => a
mempty


instance FromJSON LogStr where
    parseJSON :: Value -> Parser LogStr
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"LogStr" Text -> Parser LogStr
parseLogStr
      where
        parseLogStr :: Text -> Parser LogStr
parseLogStr = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LogStr
LogStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
B.fromText

-------------------------------------------------------------------------------
-- | Pack any string-like thing into a 'LogStr'. This will
-- automatically work on 'String', 'ByteString', 'Text' and any of the
-- lazy variants.
logStr :: StringConv a Text => a -> LogStr
logStr :: forall a. StringConv a Text => a -> LogStr
logStr a
t = Builder -> LogStr
LogStr (Text -> Builder
B.fromText forall a b. (a -> b) -> a -> b
$ forall a b. StringConv a b => a -> b
toS a
t)


-------------------------------------------------------------------------------
-- | Shorthand for 'logStr'
ls :: StringConv a Text => a -> LogStr
ls :: forall a. StringConv a Text => a -> LogStr
ls = forall a. StringConv a Text => a -> LogStr
logStr


-------------------------------------------------------------------------------
-- | Convert any showable type into a 'LogStr'.
showLS :: Show a => a -> LogStr
showLS :: forall a. Show a => a -> LogStr
showLS = forall a. StringConv a Text => a -> LogStr
ls forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show


-------------------------------------------------------------------------------
newtype ThreadIdText = ThreadIdText {
      ThreadIdText -> Text
getThreadIdText :: Text
    } deriving ([ThreadIdText] -> Encoding
[ThreadIdText] -> Value
ThreadIdText -> Bool
ThreadIdText -> Encoding
ThreadIdText -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
omitField :: ThreadIdText -> Bool
$comitField :: ThreadIdText -> Bool
toEncodingList :: [ThreadIdText] -> Encoding
$ctoEncodingList :: [ThreadIdText] -> Encoding
toJSONList :: [ThreadIdText] -> Value
$ctoJSONList :: [ThreadIdText] -> Value
toEncoding :: ThreadIdText -> Encoding
$ctoEncoding :: ThreadIdText -> Encoding
toJSON :: ThreadIdText -> Value
$ctoJSON :: ThreadIdText -> Value
ToJSON, Maybe ThreadIdText
Value -> Parser [ThreadIdText]
Value -> Parser ThreadIdText
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
omittedField :: Maybe ThreadIdText
$comittedField :: Maybe ThreadIdText
parseJSONList :: Value -> Parser [ThreadIdText]
$cparseJSONList :: Value -> Parser [ThreadIdText]
parseJSON :: Value -> Parser ThreadIdText
$cparseJSON :: Value -> Parser ThreadIdText
FromJSON, Int -> ThreadIdText -> ShowS
[ThreadIdText] -> ShowS
ThreadIdText -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ThreadIdText] -> ShowS
$cshowList :: [ThreadIdText] -> ShowS
show :: ThreadIdText -> String
$cshow :: ThreadIdText -> String
showsPrec :: Int -> ThreadIdText -> ShowS
$cshowsPrec :: Int -> ThreadIdText -> ShowS
Show, ThreadIdText -> ThreadIdText -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ThreadIdText -> ThreadIdText -> Bool
$c/= :: ThreadIdText -> ThreadIdText -> Bool
== :: ThreadIdText -> ThreadIdText -> Bool
$c== :: ThreadIdText -> ThreadIdText -> Bool
Eq, Eq ThreadIdText
ThreadIdText -> ThreadIdText -> Bool
ThreadIdText -> ThreadIdText -> Ordering
ThreadIdText -> ThreadIdText -> ThreadIdText
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 :: ThreadIdText -> ThreadIdText -> ThreadIdText
$cmin :: ThreadIdText -> ThreadIdText -> ThreadIdText
max :: ThreadIdText -> ThreadIdText -> ThreadIdText
$cmax :: ThreadIdText -> ThreadIdText -> ThreadIdText
>= :: ThreadIdText -> ThreadIdText -> Bool
$c>= :: ThreadIdText -> ThreadIdText -> Bool
> :: ThreadIdText -> ThreadIdText -> Bool
$c> :: ThreadIdText -> ThreadIdText -> Bool
<= :: ThreadIdText -> ThreadIdText -> Bool
$c<= :: ThreadIdText -> ThreadIdText -> Bool
< :: ThreadIdText -> ThreadIdText -> Bool
$c< :: ThreadIdText -> ThreadIdText -> Bool
compare :: ThreadIdText -> ThreadIdText -> Ordering
$ccompare :: ThreadIdText -> ThreadIdText -> Ordering
Ord)


mkThreadIdText :: ThreadId -> ThreadIdText
mkThreadIdText :: ThreadId -> ThreadIdText
mkThreadIdText = Text -> ThreadIdText
ThreadIdText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
stripPrefix' Text
"ThreadId " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
  where
    stripPrefix' :: Text -> Text -> Text
stripPrefix' Text
pfx Text
t = forall a. a -> Maybe a -> a
fromMaybe Text
t (Text -> Text -> Maybe Text
T.stripPrefix Text
pfx Text
t)


-------------------------------------------------------------------------------
-- | This has everything each log message will contain.
data Item a = Item {
      forall a. Item a -> Namespace
_itemApp       :: Namespace
    , forall a. Item a -> Environment
_itemEnv       :: Environment
    , forall a. Item a -> Severity
_itemSeverity  :: Severity
    , forall a. Item a -> ThreadIdText
_itemThread    :: ThreadIdText
    , forall a. Item a -> String
_itemHost      :: HostName
    , forall a. Item a -> ProcessID
_itemProcess   :: ProcessID
    , forall a. Item a -> a
_itemPayload   :: a
    , forall a. Item a -> LogStr
_itemMessage   :: LogStr
    , forall a. Item a -> UTCTime
_itemTime      :: UTCTime
    , forall a. Item a -> Namespace
_itemNamespace :: Namespace
    , forall a. Item a -> Maybe Loc
_itemLoc       :: Maybe Loc
    } deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Item a) x -> Item a
forall a x. Item a -> Rep (Item a) x
$cto :: forall a x. Rep (Item a) x -> Item a
$cfrom :: forall a x. Item a -> Rep (Item a) x
Generic, forall a b. a -> Item b -> Item a
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Item b -> Item a
$c<$ :: forall a b. a -> Item b -> Item a
fmap :: forall a b. (a -> b) -> Item a -> Item b
$cfmap :: forall a b. (a -> b) -> Item a -> Item b
Functor)
makeLenses ''Item

-- Manual instance because 'Loc' has no 'Eq' and 'Show' instances in old
-- versions of template-haskell (< 2.10)
instance Eq a => Eq (Item a) where
    Item a
a == :: Item a -> Item a -> Bool
== Item a
b = forall (t :: * -> *). Foldable t => t Bool -> Bool
FT.and [ forall a. Item a -> Namespace
_itemApp Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> Namespace
_itemApp Item a
b
                    , forall a. Item a -> Environment
_itemEnv Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> Environment
_itemEnv Item a
b
                    , forall a. Item a -> Severity
_itemSeverity Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> Severity
_itemSeverity Item a
b
                    , forall a. Item a -> ThreadIdText
_itemThread Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> ThreadIdText
_itemThread Item a
b
                    , forall a. Item a -> String
_itemHost Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> String
_itemHost Item a
b
                    , forall a. Item a -> ProcessID
_itemProcess Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> ProcessID
_itemProcess Item a
b
                    , forall a. Item a -> a
_itemPayload Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> a
_itemPayload Item a
b
                    , forall a. Item a -> LogStr
_itemMessage Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> LogStr
_itemMessage Item a
b
                    , forall a. Item a -> UTCTime
_itemTime Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> UTCTime
_itemTime Item a
b
                    , forall a. Item a -> Namespace
_itemNamespace Item a
a forall a. Eq a => a -> a -> Bool
== forall a. Item a -> Namespace
_itemNamespace Item a
b
                    , case (forall a. Item a -> Maybe Loc
_itemLoc Item a
a, forall a. Item a -> Maybe Loc
_itemLoc Item a
b) of
                        (Maybe Loc
Nothing, Maybe Loc
Nothing) -> Bool
True
                        (Just Loc
l1, Just Loc
l2) -> forall (t :: * -> *). Foldable t => t Bool -> Bool
FT.and [ Loc -> String
loc_filename Loc
l1 forall a. Eq a => a -> a -> Bool
== Loc -> String
loc_filename Loc
l2
                                                     , Loc -> String
loc_package Loc
l1 forall a. Eq a => a -> a -> Bool
== Loc -> String
loc_package Loc
l2
                                                     , Loc -> String
loc_module Loc
l1 forall a. Eq a => a -> a -> Bool
== Loc -> String
loc_module Loc
l2
                                                     , Loc -> CharPos
loc_start Loc
l1 forall a. Eq a => a -> a -> Bool
== Loc -> CharPos
loc_start Loc
l2
                                                     , Loc -> CharPos
loc_end Loc
l1 forall a. Eq a => a -> a -> Bool
== Loc -> CharPos
loc_end Loc
l2
                                                     ]
                        (Maybe Loc, Maybe Loc)
_ -> Bool
False
                    ]

instance Show a => Show (Item a) where
    showsPrec :: Int -> Item a -> ShowS
showsPrec Int
d Item{a
String
Maybe Loc
UTCTime
ProcessID
ThreadIdText
LogStr
Severity
Environment
Namespace
_itemLoc :: Maybe Loc
_itemNamespace :: Namespace
_itemTime :: UTCTime
_itemMessage :: LogStr
_itemPayload :: a
_itemProcess :: ProcessID
_itemHost :: String
_itemThread :: ThreadIdText
_itemSeverity :: Severity
_itemEnv :: Environment
_itemApp :: Namespace
_itemLoc :: forall a. Item a -> Maybe Loc
_itemNamespace :: forall a. Item a -> Namespace
_itemTime :: forall a. Item a -> UTCTime
_itemMessage :: forall a. Item a -> LogStr
_itemPayload :: forall a. Item a -> a
_itemProcess :: forall a. Item a -> ProcessID
_itemHost :: forall a. Item a -> String
_itemThread :: forall a. Item a -> ThreadIdText
_itemSeverity :: forall a. Item a -> Severity
_itemEnv :: forall a. Item a -> Environment
_itemApp :: forall a. Item a -> Namespace
..} = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
>= Int
11) ( String -> ShowS
showString String
"Item {"
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemApp" Namespace
_itemApp
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemEnv" Environment
_itemEnv
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemSeverity" Severity
_itemSeverity
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemThread" ThreadIdText
_itemThread
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemHost" String
_itemHost
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemProcess" ProcessID
_itemProcess
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemPayload" a
_itemPayload
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemMessage" LogStr
_itemMessage
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemTime" UTCTime
_itemTime
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"_itemNamespace" Namespace
_itemNamespace
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"_itemLoc = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows (Loc -> LocShow
LocShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Loc
_itemLoc)
                                               forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
                                               )
      where
        field :: String -> a -> ShowS
field String
n a
v = String -> ShowS
showString String
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows a
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", "

newtype LocShow = LocShow Loc


instance Show LocShow where
    showsPrec :: Int -> LocShow -> ShowS
showsPrec Int
d (LocShow Loc{String
CharPos
loc_end :: CharPos
loc_start :: CharPos
loc_module :: String
loc_package :: String
loc_filename :: String
loc_end :: Loc -> CharPos
loc_start :: Loc -> CharPos
loc_module :: Loc -> String
loc_package :: Loc -> String
loc_filename :: Loc -> String
..}) = Bool -> ShowS -> ShowS
showParen (Int
d forall a. Ord a => a -> a -> Bool
>= Int
11) ( String -> ShowS
showString String
"Loc {"
                                                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"loc_filename" String
loc_filename
                                                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"loc_package" String
loc_package
                                                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"loc_module" String
loc_module
                                                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Show a => String -> a -> ShowS
field String
"loc_start" CharPos
loc_start
                                                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"loc_end = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows CharPos
loc_end
                                                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
                                                        )
      where
        field :: String -> a -> ShowS
field String
n a
v = String -> ShowS
showString String
n forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" = " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows a
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", "


instance ToJSON a => ToJSON (Item a) where
    toJSON :: Item a -> Value
toJSON Item{a
String
Maybe Loc
UTCTime
ProcessID
ThreadIdText
LogStr
Severity
Environment
Namespace
_itemLoc :: Maybe Loc
_itemNamespace :: Namespace
_itemTime :: UTCTime
_itemMessage :: LogStr
_itemPayload :: a
_itemProcess :: ProcessID
_itemHost :: String
_itemThread :: ThreadIdText
_itemSeverity :: Severity
_itemEnv :: Environment
_itemApp :: Namespace
_itemLoc :: forall a. Item a -> Maybe Loc
_itemNamespace :: forall a. Item a -> Namespace
_itemTime :: forall a. Item a -> UTCTime
_itemMessage :: forall a. Item a -> LogStr
_itemPayload :: forall a. Item a -> a
_itemProcess :: forall a. Item a -> ProcessID
_itemHost :: forall a. Item a -> String
_itemThread :: forall a. Item a -> ThreadIdText
_itemSeverity :: forall a. Item a -> Severity
_itemEnv :: forall a. Item a -> Environment
_itemApp :: forall a. Item a -> Namespace
..} = [Pair] -> Value
A.object
      [ Key
"app" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= Namespace
_itemApp
      , Key
"env" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= Environment
_itemEnv
      , Key
"sev" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= Severity
_itemSeverity
      , Key
"thread" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= ThreadIdText -> Text
getThreadIdText ThreadIdText
_itemThread
      , Key
"host" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= String
_itemHost
      , Key
"pid" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= ProcessID -> ProcessIDJs
ProcessIDJs ProcessID
_itemProcess
      , Key
"data" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= a
_itemPayload
      , Key
"msg" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= (Builder -> Text
B.toLazyText forall a b. (a -> b) -> a -> b
$ LogStr -> Builder
unLogStr LogStr
_itemMessage)
      , Key
"at" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= UTCTime
_itemTime
      , Key
"ns" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= Namespace
_itemNamespace
      , Key
"loc" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Loc -> LocJs
LocJs Maybe Loc
_itemLoc
      ]

newtype LocJs = LocJs { LocJs -> Loc
getLocJs :: Loc }


instance ToJSON LocJs where
    toJSON :: LocJs -> Value
toJSON (LocJs (Loc String
fn String
p String
m (Int
l, Int
c) CharPos
_)) = [Pair] -> Value
A.object
      [ Key
"loc_fn" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= String
fn
      , Key
"loc_pkg" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= String
p
      , Key
"loc_mod" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= String
m
      , Key
"loc_ln" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= Int
l
      , Key
"loc_col" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= Int
c
      ]


instance FromJSON LocJs where
    parseJSON :: Value -> Parser LocJs
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"LocJs" Object -> Parser LocJs
parseLocJs
      where
        parseLocJs :: Object -> Parser LocJs
parseLocJs Object
o = do
          String
fn <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"loc_fn"
          String
p <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"loc_pkg"
          String
m <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"loc_mod"
          Int
l <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"loc_ln"
          Int
c <- Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"loc_col"
          forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Loc -> LocJs
LocJs forall a b. (a -> b) -> a -> b
$ String -> String -> String -> CharPos -> CharPos -> Loc
Loc String
fn String
p String
m (Int
l, Int
c) (Int
l, Int
c)


instance FromJSON a => FromJSON (Item a) where
    parseJSON :: Value -> Parser (Item a)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Item" forall {a}. FromJSON a => Object -> Parser (Item a)
parseItem
      where
        parseItem :: Object -> Parser (Item a)
parseItem Object
o = forall a.
Namespace
-> Environment
-> Severity
-> ThreadIdText
-> String
-> ProcessID
-> a
-> LogStr
-> UTCTime
-> Namespace
-> Maybe Loc
-> Item a
Item
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"app"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"env"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"sev"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"thread"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"host"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ProcessIDJs -> ProcessID
getProcessIDJs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"pid")
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"data"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"msg"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"at"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"ns"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocJs -> Loc
getLocJs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Key -> Parser a
A..: Key
"loc")


processIDToText :: ProcessID -> Text
processIDToText :: ProcessID -> Text
processIDToText = forall a b. StringConv a b => a -> b
toS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show


textToProcessID :: Text -> Maybe ProcessID
textToProcessID :: Text -> Maybe ProcessID
textToProcessID = forall a. Read a => String -> Maybe a
readMay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. StringConv a b => a -> b
toS


newtype ProcessIDJs = ProcessIDJs {
      ProcessIDJs -> ProcessID
getProcessIDJs :: ProcessID
    }


instance ToJSON ProcessIDJs where
    toJSON :: ProcessIDJs -> Value
toJSON (ProcessIDJs ProcessID
p) = Text -> Value
A.String (ProcessID -> Text
processIDToText ProcessID
p)


instance FromJSON ProcessIDJs where
    parseJSON :: Value -> Parser ProcessIDJs
parseJSON = forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"ProcessID" forall {m :: * -> *}. MonadFail m => Text -> m ProcessIDJs
parseProcessID
      where
        parseProcessID :: Text -> m ProcessIDJs
parseProcessID Text
t = case Text -> Maybe ProcessID
textToProcessID Text
t of
          Just ProcessID
p  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProcessID -> ProcessIDJs
ProcessIDJs ProcessID
p
          Maybe ProcessID
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid ProcessIDJs " forall a. [a] -> [a] -> [a]
++ forall a b. StringConv a b => a -> b
toS Text
t


-------------------------------------------------------------------------------
-- | Field selector by verbosity within JSON payload.
data PayloadSelection
    = AllKeys
    | SomeKeys [Text]
    deriving (Int -> PayloadSelection -> ShowS
[PayloadSelection] -> ShowS
PayloadSelection -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PayloadSelection] -> ShowS
$cshowList :: [PayloadSelection] -> ShowS
show :: PayloadSelection -> String
$cshow :: PayloadSelection -> String
showsPrec :: Int -> PayloadSelection -> ShowS
$cshowsPrec :: Int -> PayloadSelection -> ShowS
Show, PayloadSelection -> PayloadSelection -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PayloadSelection -> PayloadSelection -> Bool
$c/= :: PayloadSelection -> PayloadSelection -> Bool
== :: PayloadSelection -> PayloadSelection -> Bool
$c== :: PayloadSelection -> PayloadSelection -> Bool
Eq)

instance Semigroup PayloadSelection where
  PayloadSelection
AllKeys <> :: PayloadSelection -> PayloadSelection -> PayloadSelection
<> PayloadSelection
_ = PayloadSelection
AllKeys
  PayloadSelection
_ <> PayloadSelection
AllKeys = PayloadSelection
AllKeys
  SomeKeys [Text]
as <> SomeKeys [Text]
bs = [Text] -> PayloadSelection
SomeKeys ([Text]
as forall a. Semigroup a => a -> a -> a
<> [Text]
bs)


instance Monoid PayloadSelection where
    mempty :: PayloadSelection
mempty = [Text] -> PayloadSelection
SomeKeys []
    mappend :: PayloadSelection -> PayloadSelection -> PayloadSelection
mappend = forall a. Semigroup a => a -> a -> a
(<>)


-- | Compares two payload selections for equivalence. With SomeKeys, ordering
-- and duplicates are ignored.
equivalentPayloadSelection :: PayloadSelection -> PayloadSelection -> Bool
equivalentPayloadSelection :: PayloadSelection -> PayloadSelection -> Bool
equivalentPayloadSelection PayloadSelection
AllKeys PayloadSelection
AllKeys = Bool
True
equivalentPayloadSelection (SomeKeys [Text]
a) (SomeKeys [Text]
b) = forall a. Ord a => [a] -> Set a
Set.fromList [Text]
a forall a. Eq a => a -> a -> Bool
== forall a. Ord a => [a] -> Set a
Set.fromList [Text]
b
equivalentPayloadSelection PayloadSelection
_ PayloadSelection
_ = Bool
False

-------------------------------------------------------------------------------
-- | Katip requires JSON objects to be logged as context. This
-- typeclass provides a default instance which uses ToJSON and
-- produces an empty object if 'toJSON' results in any type other than
-- object. If you have a type you want to log that produces an Array
-- or Number for example, you'll want to write an explicit instance
-- here. You can trivially add a ToObject instance for something with
-- a ToJSON instance like:
--
-- > instance ToObject Foo
class ToObject a where
    toObject :: a -> A.Object
    default toObject :: ToJSON a => a -> A.Object
    toObject a
v = case forall a. ToJSON a => a -> Value
toJSON a
v of
      A.Object Object
o -> Object
o
      Value
_          -> forall a. Monoid a => a
mempty

instance ToObject ()
instance ToObject A.Object

-------------------------------------------------------------------------------
-- | Payload objects need instances of this class. LogItem makes it so
-- that you can have very verbose items getting logged with lots of
-- extra fields but under normal circumstances, if your scribe is
-- configured for a lower verbosity level, it will only log a
-- selection of those keys. Furthermore, each 'Scribe' can be
-- configured with a different 'Verbosity' level. You could even use
-- 'registerScribe', 'unregisterScribe', and 'clearScribes' to at
-- runtime swap out your existing scribes for more verbose debugging
-- scribes if you wanted to.
--
-- When defining 'payloadKeys', don't redundantly declare the same
-- keys for higher levels of verbosity. Each level of verbosity
-- automatically and recursively contains all keys from the level
-- before it.
class ToObject a => LogItem a where

    -- | List of keys in the JSON object that should be included in message.
    payloadKeys :: Verbosity -> a -> PayloadSelection


instance LogItem () where payloadKeys :: Verbosity -> () -> PayloadSelection
payloadKeys Verbosity
_ ()
_ = [Text] -> PayloadSelection
SomeKeys []


data AnyLogPayload = forall a. ToJSON a => AnyLogPayload a

newtype SimpleLogPayload = SimpleLogPayload {
      SimpleLogPayload -> [(Text, AnyLogPayload)]
unSimpleLogPayload :: [(Text, AnyLogPayload)]
    }

-------------------------------------------------------------------------------
-- | A built-in convenience log payload that won't log anything on 'V0',
-- but will log everything in any other level of verbosity. Intended
-- for easy in-line usage without having to define new log types.
--
-- Construct using 'sl' and combine multiple tuples using '<>' from
-- 'Monoid'.
instance ToJSON SimpleLogPayload where
    toJSON :: SimpleLogPayload -> Value
toJSON (SimpleLogPayload [(Text, AnyLogPayload)]
as) = [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {e} {p}. KeyValue e p => (Key, AnyLogPayload) -> p
go [(Key, AnyLogPayload)]
as'
      where go :: (Key, AnyLogPayload) -> p
go (Key
k, AnyLogPayload a
v) = Key
k forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= a
v
            as' :: [(Key, AnyLogPayload)]
as' = forall c. (Text, c) -> (Key, c)
toKey forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, AnyLogPayload)]
as


#if MIN_VERSION_aeson(2, 0, 0)
toKey :: (Text, c) -> (K.Key, c)
toKey :: forall c. (Text, c) -> (Key, c)
toKey = forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> Key
K.fromText
#else
toKey :: a -> a
toKey = id
#endif


instance ToObject SimpleLogPayload


instance LogItem SimpleLogPayload where
    payloadKeys :: Verbosity -> SimpleLogPayload -> PayloadSelection
payloadKeys Verbosity
V0 SimpleLogPayload
_ = [Text] -> PayloadSelection
SomeKeys []
    payloadKeys Verbosity
_ SimpleLogPayload
_  = PayloadSelection
AllKeys


instance Semigroup SimpleLogPayload where
  SimpleLogPayload [(Text, AnyLogPayload)]
a <> :: SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
<> SimpleLogPayload [(Text, AnyLogPayload)]
b = [(Text, AnyLogPayload)] -> SimpleLogPayload
SimpleLogPayload ([(Text, AnyLogPayload)]
a forall a. Semigroup a => a -> a -> a
<> [(Text, AnyLogPayload)]
b)


instance Monoid SimpleLogPayload where
    mempty :: SimpleLogPayload
mempty = [(Text, AnyLogPayload)] -> SimpleLogPayload
SimpleLogPayload []
    mappend :: SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
mappend = forall a. Semigroup a => a -> a -> a
(<>)


-------------------------------------------------------------------------------
-- | Construct a simple log from any JSON item.
sl :: ToJSON a => Text -> a -> SimpleLogPayload
sl :: forall a. ToJSON a => Text -> a -> SimpleLogPayload
sl Text
a a
b = [(Text, AnyLogPayload)] -> SimpleLogPayload
SimpleLogPayload [(Text
a, forall a. ToJSON a => a -> AnyLogPayload
AnyLogPayload a
b)]


-------------------------------------------------------------------------------
-- | Constrain payload based on verbosity. Backends should use this to
-- automatically bubble higher verbosity levels to lower ones.
payloadObject :: LogItem a => Verbosity -> a -> A.Object
payloadObject :: forall a. LogItem a => Verbosity -> a -> Object
payloadObject Verbosity
verb a
a = case forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
FT.foldMap (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. LogItem a => Verbosity -> a -> PayloadSelection
payloadKeys a
a) [(Verbosity
V0)..Verbosity
verb] of
    PayloadSelection
AllKeys     -> forall a. ToObject a => a -> Object
toObject a
a
    SomeKeys [Text]
ks -> forall v. [Text] -> KeyMap v -> KeyMap v
filterElems [Text]
ks forall a b. (a -> b) -> a -> b
$ forall a. ToObject a => a -> Object
toObject a
a

#if MIN_VERSION_aeson(2, 0, 0)
filterElems :: [Text] -> KM.KeyMap v -> KM.KeyMap v
filterElems :: forall v. [Text] -> KeyMap v -> KeyMap v
filterElems [Text]
ks = forall v. (Key -> v -> Bool) -> KeyMap v -> KeyMap v
KM.filterWithKey (\ Key
k v
_ -> Key -> Text
K.toText Key
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`FT.elem` [Text]
ks)
#else
filterElems :: [Text] -> HM.HashMap Text v -> HM.HashMap Text v
filterElems ks = HM.filterWithKey (\ k _ -> k `FT.elem` ks)
#endif


-------------------------------------------------------------------------------
-- | Convert log item to its JSON representation while trimming its
-- payload based on the desired verbosity. Backends that push JSON
-- messages should use this to obtain their payload.
itemJson :: LogItem a => Verbosity -> Item a -> A.Value
itemJson :: forall a. LogItem a => Verbosity -> Item a -> Value
itemJson Verbosity
verb Item a
a = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ Item a
a forall a b. a -> (a -> b) -> b
& forall a a. Lens (Item a) (Item a) a a
itemPayload forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. LogItem a => Verbosity -> a -> Object
payloadObject Verbosity
verb


-------------------------------------------------------------------------------
-- | Scribes are handlers of incoming items. Each registered scribe
-- knows how to push a log item somewhere.
--
-- = Guidelines for writing your own 'Scribe'
--
-- Scribes should always take a 'Severity' and 'Verbosity'.
--
-- Severity is used to __exclude log messages__ that are lower than
-- the provided Severity. For instance, if the user passes InfoS,
-- DebugS items should be ignored. Katip provides the 'permitItem'
-- utility for this. The user or the scribe may use 'permitAND' and
-- 'permitOR' to further customize this filtering, even dynamically if
-- they wish to.
--
-- Verbosity is used to select keys from the log item's payload. Each
-- 'LogItem' instance describes what keys should be retained for each
-- Verbosity level. Use the 'payloadObject' utility for extracting the keys
-- that should be written.
--
-- Scribes provide a finalizer IO action ('scribeFinalizer') that is
-- meant to synchronously flush any remaining writes and clean up any
-- resources acquired when the scribe was created. Internally, katip
-- keeps a buffer for each scribe's writes. When 'closeScribe' or
-- 'closeScribes' is called, that buffer stops accepting new log
-- messages and after the last item in its buffer is sent to 'liPush',
-- calls the finalizer. Thus, when the finalizer returns, katip can
-- assume that all resources are cleaned up and all log messages are
-- durably written.
--
-- While katip internally buffers messages per 'ScribeSettings', it
-- sends them one at a time to the scribe. Depending on the scribe
-- itself, it may make sense for that scribe to keep its own internal
-- buffer to batch-send logs if writing items one at a time is not
-- efficient. The scribe implementer must be sure that on
-- finalization, all writes are committed synchronously.

-- | Signature of a function passed to `Scribe` constructor and
--   mkScribe* functions that decides which messages to be
--   logged. Typically filters based on 'Severity', but can be
--   combined with other, custom logic with 'permitAND' and 'permitOR'
type PermitFunc = forall a. Item a -> IO Bool


-- | AND together 2 permit functions
permitAND :: PermitFunc -> PermitFunc -> PermitFunc
permitAND :: PermitFunc -> PermitFunc -> PermitFunc
permitAND PermitFunc
f1 PermitFunc
f2 = \Item a
a -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) (PermitFunc
f1 Item a
a) (PermitFunc
f2 Item a
a)

-- | OR together 2 permit functions
permitOR :: PermitFunc -> PermitFunc -> PermitFunc
permitOR :: PermitFunc -> PermitFunc -> PermitFunc
permitOR PermitFunc
f1 PermitFunc
f2 = \Item a
a -> forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) (PermitFunc
f1 Item a
a) (PermitFunc
f2 Item a
a)


data Scribe = Scribe {
     Scribe -> forall a. LogItem a => Item a -> IO ()
liPush           :: forall a. LogItem a => Item a -> IO ()
   -- ^ How do we write an item to the scribe's output?
   , Scribe -> IO ()
scribeFinalizer  :: IO ()
   -- ^ Provide a __blocking__ finalizer to call when your scribe is
   -- removed. All pending writes should be flushed synchronously. If
   -- this is not relevant to your scribe, return () is fine.
   , Scribe -> PermitFunc
scribePermitItem :: PermitFunc
   -- ^ Provide a filtering function to allow the item to be logged,
   --   or not.  It can check Severity or some string in item's
   --   body. The initial value of this is usually created from
   --   'permitItem'. Scribes and users can customize this by ANDing
   --   or ORing onto the default with 'permitAND' or 'permitOR'
   }


whenM :: Monad m => m Bool -> m () -> m ()
whenM :: forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
mbool = forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) m Bool
mbool forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when


-- | Combine two scribes. Publishes to the left scribe if the left
-- would permit the item and to the right scribe if the right would
-- permit the item. Finalizers are called in sequence from left to
-- right.
instance Semigroup Scribe where
  (Scribe forall a. LogItem a => Item a -> IO ()
pushA IO ()
finA PermitFunc
permitA) <> :: Scribe -> Scribe -> Scribe
<> (Scribe forall a. LogItem a => Item a -> IO ()
pushB IO ()
finB PermitFunc
permitB) =
    (forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
Scribe (\Item a
item -> forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (PermitFunc
permitA Item a
item) (forall a. LogItem a => Item a -> IO ()
pushA Item a
item)
                  forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (PermitFunc
permitB Item a
item) (forall a. LogItem a => Item a -> IO ()
pushB Item a
item)
           )
           (IO ()
finA forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` IO ()
finB)
           (PermitFunc -> PermitFunc -> PermitFunc
permitOR PermitFunc
permitA PermitFunc
permitB)


instance Monoid Scribe where
    mempty :: Scribe
mempty = (forall a. LogItem a => Item a -> IO ())
-> IO () -> PermitFunc -> Scribe
Scribe (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())) (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (forall (m :: * -> *) a. Monad m => Severity -> Item a -> m Bool
permitItem Severity
DebugS)
    mappend :: Scribe -> Scribe -> Scribe
mappend = forall a. Semigroup a => a -> a -> a
(<>)


-------------------------------------------------------------------------------
data ScribeHandle = ScribeHandle {
      ScribeHandle -> Scribe
shScribe :: Scribe
    , ScribeHandle -> TBQueue WorkerMessage
shChan   :: BQ.TBQueue WorkerMessage
    }


-------------------------------------------------------------------------------
data WorkerMessage where
  NewItem    :: LogItem a => Item a -> WorkerMessage
  PoisonPill :: WorkerMessage


-------------------------------------------------------------------------------
-- | Should this item be logged given the user's maximum severity?
-- Most new scribes will use this as a base for their 'PermitFunc'
permitItem :: Monad m => Severity -> Item a -> m Bool
permitItem :: forall (m :: * -> *) a. Monad m => Severity -> Item a -> m Bool
permitItem Severity
sev Item a
item = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Item a -> Severity
_itemSeverity Item a
item forall a. Ord a => a -> a -> Bool
>= Severity
sev)


-------------------------------------------------------------------------------
data LogEnv = LogEnv {
      LogEnv -> String
_logEnvHost    :: HostName
    , LogEnv -> ProcessID
_logEnvPid     :: ProcessID
    , LogEnv -> Namespace
_logEnvApp     :: Namespace
    -- ^ Name of application. This will typically never change. This
    -- field gets prepended to the namespace of your individual log
    -- messages. For example, if your app is MyApp and you write a log
    -- using "logItem" and the namespace "WebServer", the final
    -- namespace will be "MyApp.WebServer"
    , LogEnv -> Environment
_logEnvEnv     :: Environment
    , LogEnv -> IO UTCTime
_logEnvTimer   :: IO UTCTime
    -- ^ Action to fetch the timestamp. You can use something like
    -- 'AutoUpdate' for high volume logs but note that this may cause
    -- some output forms to display logs out of order. Alternatively,
    -- you could just use 'getCurrentTime'.
    , LogEnv -> Map Text ScribeHandle
_logEnvScribes :: M.Map Text ScribeHandle
    }
makeLenses ''LogEnv


-------------------------------------------------------------------------------
-- | Create a reasonable default InitLogEnv. Uses an 'AutoUpdate' which
-- updates the timer every 1ms. If you need even more timestamp
-- precision at the cost of performance, consider setting
-- '_logEnvTimer' with 'getCurrentTime'.
initLogEnv
    :: Namespace
    -- ^ A base namespace for this application
    -> Environment
    -- ^ Current run environment (e.g. @prod@ vs. @devel@)
    -> IO LogEnv
initLogEnv :: Namespace -> Environment -> IO LogEnv
initLogEnv Namespace
an Environment
env = String
-> ProcessID
-> Namespace
-> Environment
-> IO UTCTime
-> Map Text ScribeHandle
-> LogEnv
LogEnv
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHostName
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO ProcessID
getProcessID
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Namespace
an
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Environment
env
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings ()
defaultUpdateSettings { updateAction :: IO UTCTime
updateAction = IO UTCTime
getCurrentTime, updateFreq :: Int
updateFreq = Int
1000 }
  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty


-------------------------------------------------------------------------------
-- | Add a scribe to the list. All future log calls will go to this
-- scribe in addition to the others. Writes will be buffered per the
-- ScribeSettings to prevent slow scribes from slowing down
-- logging. Writes will be dropped if the buffer fills.
registerScribe
    :: Text
    -- ^ Name the scribe
    -> Scribe
    -> ScribeSettings
    -> LogEnv
    -> IO LogEnv
registerScribe :: Text -> Scribe -> ScribeSettings -> LogEnv -> IO LogEnv
registerScribe Text
nm Scribe
scribe ScribeSettings {Int
_scribeBufferSize :: ScribeSettings -> Int
_scribeBufferSize :: Int
..} LogEnv
le = do
  TBQueue WorkerMessage
queue <- forall a. STM a -> IO a
atomically (forall a. Natural -> STM (TBQueue a)
BQ.newTBQueue (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
_scribeBufferSize))
  Async ()
worker <- Scribe -> TBQueue WorkerMessage -> IO (Async ())
spawnScribeWorker Scribe
scribe TBQueue WorkerMessage
queue
  let fin :: IO ()
fin = do
        forall a. STM a -> IO a
atomically (forall a. TBQueue a -> a -> STM ()
BQ.writeTBQueue TBQueue WorkerMessage
queue WorkerMessage
PoisonPill)
        -- wait for our worker to finish final write
        forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall a. Async a -> IO (Either SomeException a)
Async.waitCatch Async ()
worker)
        -- wait for scribe to finish final write
        forall (f :: * -> *) a. Functor f => f a -> f ()
void (Scribe -> IO ()
scribeFinalizer Scribe
scribe)

  let sh :: ScribeHandle
sh = Scribe -> TBQueue WorkerMessage -> ScribeHandle
ScribeHandle (Scribe
scribe { scribeFinalizer :: IO ()
scribeFinalizer = IO ()
fin }) TBQueue WorkerMessage
queue
  forall (m :: * -> *) a. Monad m => a -> m a
return (LogEnv
le forall a b. a -> (a -> b) -> b
& Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
nm ScribeHandle
sh)


-------------------------------------------------------------------------------
spawnScribeWorker :: Scribe -> BQ.TBQueue WorkerMessage -> IO (Async.Async ())
spawnScribeWorker :: Scribe -> TBQueue WorkerMessage -> IO (Async ())
spawnScribeWorker (Scribe forall a. LogItem a => Item a -> IO ()
write IO ()
_ PermitFunc
_) TBQueue WorkerMessage
queue = forall a. IO a -> IO (Async a)
Async.async IO ()
go
  where
    go :: IO ()
go = do
      WorkerMessage
newCmd <- forall a. STM a -> IO a
atomically (forall a. TBQueue a -> STM a
BQ.readTBQueue TBQueue WorkerMessage
queue)
      case WorkerMessage
newCmd of
        NewItem Item a
a  -> do
          -- Swallow any direct exceptions from the
          -- scribe. safe-exceptions won't catch async exceptions.
          forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny (forall a. LogItem a => Item a -> IO ()
write Item a
a))
          IO ()
go
        WorkerMessage
PoisonPill -> forall (m :: * -> *) a. Monad m => a -> m a
return ()


-------------------------------------------------------------------------------
data ScribeSettings = ScribeSettings {
      ScribeSettings -> Int
_scribeBufferSize :: Int
    }
  deriving (Int -> ScribeSettings -> ShowS
[ScribeSettings] -> ShowS
ScribeSettings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScribeSettings] -> ShowS
$cshowList :: [ScribeSettings] -> ShowS
show :: ScribeSettings -> String
$cshow :: ScribeSettings -> String
showsPrec :: Int -> ScribeSettings -> ShowS
$cshowsPrec :: Int -> ScribeSettings -> ShowS
Show, ScribeSettings -> ScribeSettings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScribeSettings -> ScribeSettings -> Bool
$c/= :: ScribeSettings -> ScribeSettings -> Bool
== :: ScribeSettings -> ScribeSettings -> Bool
$c== :: ScribeSettings -> ScribeSettings -> Bool
Eq)

makeLenses ''ScribeSettings


-- | Reasonable defaults for a scribe. Buffer
-- size of 4096.
defaultScribeSettings :: ScribeSettings
defaultScribeSettings :: ScribeSettings
defaultScribeSettings = Int -> ScribeSettings
ScribeSettings Int
4096


-------------------------------------------------------------------------------
-- | Remove a scribe from the environment. This does __not__ finalize
-- the scribe. This mainly only makes sense to use with something like
-- MonadReader's @local@ function to temporarily disavow a single
-- logger for a block of code.
unregisterScribe
    :: Text
    -- ^ Name of the scribe
    -> LogEnv
    -> LogEnv
unregisterScribe :: Text -> LogEnv -> LogEnv
unregisterScribe Text
nm =  Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> Map k a -> Map k a
M.delete Text
nm


-------------------------------------------------------------------------------
-- | Unregister __all__ scribes. Note that this is __not__ for closing or
-- finalizing scribes, use 'closeScribes' for that. This mainly only
-- makes sense to use with something like MonadReader's @local@
-- function to temporarily disavow any loggers for a block of code.
clearScribes
    :: LogEnv
    -> LogEnv
clearScribes :: LogEnv -> LogEnv
clearScribes = Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty


-------------------------------------------------------------------------------
-- | Finalize a scribe. The scribe is removed from the environment,
-- its finalizer is called so that it can never be written to again
-- and all pending writes are flushed. Note that this will throw any
-- exceptions yoru finalizer will throw, and that LogEnv is immutable,
-- so it will not be removed in that case.
closeScribe
    :: Text
    -- ^ Name of the scribe
    -> LogEnv
    -> IO LogEnv
closeScribe :: Text -> LogEnv -> IO LogEnv
closeScribe Text
nm LogEnv
le = do
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Scribe -> IO ()
scribeFinalizer forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScribeHandle -> Scribe
shScribe) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
nm (LogEnv -> Map Text ScribeHandle
_logEnvScribes LogEnv
le))
  forall (m :: * -> *) a. Monad m => a -> m a
return (LogEnv
le forall a b. a -> (a -> b) -> b
& Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => k -> Map k a -> Map k a
M.delete Text
nm)


-------------------------------------------------------------------------------
-- | Call this at the end of your program. This is a blocking call
-- that stop writing to a scribe's queue, waits for the queue to
-- empty, finalizes each scribe in the log environment and then
-- removes it. Finalizers are all run even if one of them throws, but
-- the exception will be re-thrown at the end.
closeScribes
    :: LogEnv
    -> IO LogEnv
closeScribes :: LogEnv -> IO LogEnv
closeScribes LogEnv
le = do
  -- We want to run every finalizer here so we'll not save
  -- intermediate logenvs and just clear scribes at the end.
  let actions :: [IO ()]
actions = [forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> LogEnv -> IO LogEnv
closeScribe Text
k LogEnv
le) | Text
k <- forall k a. Map k a -> [k]
M.keys (LogEnv -> Map Text ScribeHandle
_logEnvScribes LogEnv
le)]
  forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
FT.foldr forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (forall (m :: * -> *) a. Monad m => a -> m a
return ()) [IO ()]
actions
  forall (m :: * -> *) a. Monad m => a -> m a
return (LogEnv
le forall a b. a -> (a -> b) -> b
& Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Monoid a => a
mempty)


-------------------------------------------------------------------------------
-- | Monads where katip logging actions can be performed. Katip is the
-- most basic logging monad. You will typically use this directly if
-- you either don't want to use namespaces/contexts heavily or if you
-- want to pass in specific contexts and/or namespaces at each log site.
--
-- For something more powerful, look at the docs for 'KatipContext',
-- which keeps a namespace and merged context. You can write simple
-- functions that add additional namespacing and merges additional
-- context on the fly.
--
-- 'localLogEnv' was added to allow for lexically-scoped modifications
-- of the log env that are reverted when the supplied monad
-- completes. 'katipNoLogging', for example, uses this to temporarily
-- pause log outputs.
class MonadIO m => Katip m where
    getLogEnv :: m LogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> m a -> m a


instance Katip m => Katip (ReaderT s m) where
    getLogEnv :: ReaderT s m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> ReaderT s m a -> ReaderT s m a
localLogEnv = forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


#if !MIN_VERSION_either(4, 5, 0)
instance Katip m => Katip (EitherT s m) where
    getLogEnv = lift getLogEnv
    localLogEnv = mapEitherT . localLogEnv
#endif


instance Katip m => Katip (ExceptT s m) where
    getLogEnv :: ExceptT s m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> ExceptT s m a -> ExceptT s m a
localLogEnv = forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance Katip m => Katip (MaybeT m) where
    getLogEnv :: MaybeT m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> MaybeT m a -> MaybeT m a
localLogEnv = forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance Katip m => Katip (StateT s m) where
    getLogEnv :: StateT s m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> StateT s m a -> StateT s m a
localLogEnv = forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance (Katip m, Monoid w) => Katip (RWST r w s m) where
    getLogEnv :: RWST r w s m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> RWST r w s m a -> RWST r w s m a
localLogEnv = forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
mapRWST forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance (Katip m, Monoid w) => Katip (Strict.RWST r w s m) where
    getLogEnv :: RWST r w s m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> RWST r w s m a -> RWST r w s m a
localLogEnv = forall (m :: * -> *) a s w (n :: * -> *) b w' r.
(m (a, s, w) -> n (b, s, w')) -> RWST r w s m a -> RWST r w' s n b
Strict.mapRWST forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance Katip m => Katip (Strict.StateT s m) where
    getLogEnv :: StateT s m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> StateT s m a -> StateT s m a
localLogEnv = forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Strict.mapStateT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance (Katip m, Monoid s) => Katip (WriterT s m) where
    getLogEnv :: WriterT s m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> WriterT s m a -> WriterT s m a
localLogEnv = forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance (Katip m, Monoid s) => Katip (Strict.WriterT s m) where
    getLogEnv :: WriterT s m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> WriterT s m a -> WriterT s m a
localLogEnv = forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Strict.mapWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance (Katip m) => Katip (ResourceT m) where
    getLogEnv :: ResourceT m LogEnv
getLogEnv = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> ResourceT m a -> ResourceT m a
localLogEnv = forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


-------------------------------------------------------------------------------
-- | A concrete monad you can use to run logging actions. Use this if
-- you prefer an explicit monad transformer stack and adding layers as
-- opposed to implementing 'Katip' for your monad.
newtype KatipT m a = KatipT { forall (m :: * -> *) a. KatipT m a -> ReaderT LogEnv m a
unKatipT :: ReaderT LogEnv m a }
  deriving ( forall a b. a -> KatipT m b -> KatipT m a
forall a b. (a -> b) -> KatipT m a -> KatipT m b
forall (m :: * -> *) a b.
Functor m =>
a -> KatipT m b -> KatipT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> KatipT m a -> KatipT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> KatipT m b -> KatipT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> KatipT m b -> KatipT m a
fmap :: forall a b. (a -> b) -> KatipT m a -> KatipT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> KatipT m a -> KatipT m b
Functor, forall a. a -> KatipT m a
forall a b. KatipT m a -> KatipT m b -> KatipT m a
forall a b. KatipT m a -> KatipT m b -> KatipT m b
forall a b. KatipT m (a -> b) -> KatipT m a -> KatipT m b
forall a b c.
(a -> b -> c) -> KatipT m a -> KatipT m b -> KatipT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {m :: * -> *}. Applicative m => Functor (KatipT m)
forall (m :: * -> *) a. Applicative m => a -> KatipT m a
forall (m :: * -> *) a b.
Applicative m =>
KatipT m a -> KatipT m b -> KatipT m a
forall (m :: * -> *) a b.
Applicative m =>
KatipT m a -> KatipT m b -> KatipT m b
forall (m :: * -> *) a b.
Applicative m =>
KatipT m (a -> b) -> KatipT m a -> KatipT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> KatipT m a -> KatipT m b -> KatipT m c
<* :: forall a b. KatipT m a -> KatipT m b -> KatipT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
KatipT m a -> KatipT m b -> KatipT m a
*> :: forall a b. KatipT m a -> KatipT m b -> KatipT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
KatipT m a -> KatipT m b -> KatipT m b
liftA2 :: forall a b c.
(a -> b -> c) -> KatipT m a -> KatipT m b -> KatipT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> KatipT m a -> KatipT m b -> KatipT m c
<*> :: forall a b. KatipT m (a -> b) -> KatipT m a -> KatipT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
KatipT m (a -> b) -> KatipT m a -> KatipT m b
pure :: forall a. a -> KatipT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> KatipT m a
Applicative, forall a. a -> KatipT m a
forall a b. KatipT m a -> KatipT m b -> KatipT m b
forall a b. KatipT m a -> (a -> KatipT m b) -> KatipT m b
forall {m :: * -> *}. Monad m => Applicative (KatipT m)
forall (m :: * -> *) a. Monad m => a -> KatipT m a
forall (m :: * -> *) a b.
Monad m =>
KatipT m a -> KatipT m b -> KatipT m b
forall (m :: * -> *) a b.
Monad m =>
KatipT m a -> (a -> KatipT m b) -> KatipT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> KatipT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> KatipT m a
>> :: forall a b. KatipT m a -> KatipT m b -> KatipT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
KatipT m a -> KatipT m b -> KatipT m b
>>= :: forall a b. KatipT m a -> (a -> KatipT m b) -> KatipT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
KatipT m a -> (a -> KatipT m b) -> KatipT m b
Monad, forall a. IO a -> KatipT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (KatipT m)
forall (m :: * -> *) a. MonadIO m => IO a -> KatipT m a
liftIO :: forall a. IO a -> KatipT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> KatipT m a
MonadIO
           , forall b.
((forall a. KatipT m a -> KatipT m a) -> KatipT m b) -> KatipT m b
forall a b c.
KatipT m a
-> (a -> ExitCase b -> KatipT m c)
-> (a -> KatipT m b)
-> KatipT m (b, c)
forall {m :: * -> *}. MonadMask m => MonadCatch (KatipT m)
forall (m :: * -> *) b.
MonadMask m =>
((forall a. KatipT m a -> KatipT m a) -> KatipT m b) -> KatipT m b
forall (m :: * -> *) a b c.
MonadMask m =>
KatipT m a
-> (a -> ExitCase b -> KatipT m c)
-> (a -> KatipT m b)
-> KatipT m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
KatipT m a
-> (a -> ExitCase b -> KatipT m c)
-> (a -> KatipT m b)
-> KatipT m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
MonadMask m =>
KatipT m a
-> (a -> ExitCase b -> KatipT m c)
-> (a -> KatipT m b)
-> KatipT m (b, c)
uninterruptibleMask :: forall b.
((forall a. KatipT m a -> KatipT m a) -> KatipT m b) -> KatipT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. KatipT m a -> KatipT m a) -> KatipT m b) -> KatipT m b
mask :: forall b.
((forall a. KatipT m a -> KatipT m a) -> KatipT m b) -> KatipT m b
$cmask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. KatipT m a -> KatipT m a) -> KatipT m b) -> KatipT m b
MonadMask, forall e a.
Exception e =>
KatipT m a -> (e -> KatipT m a) -> KatipT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall {m :: * -> *}. MonadCatch m => MonadThrow (KatipT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
KatipT m a -> (e -> KatipT m a) -> KatipT m a
catch :: forall e a.
Exception e =>
KatipT m a -> (e -> KatipT m a) -> KatipT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
KatipT m a -> (e -> KatipT m a) -> KatipT m a
MonadCatch, forall e a. Exception e => e -> KatipT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall {m :: * -> *}. MonadThrow m => Monad (KatipT m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> KatipT m a
throwM :: forall e a. Exception e => e -> KatipT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> KatipT m a
MonadThrow, forall a. ResourceT IO a -> KatipT m a
forall (m :: * -> *).
MonadIO m -> (forall a. ResourceT IO a -> m a) -> MonadResource m
forall {m :: * -> *}. MonadResource m => MonadIO (KatipT m)
forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> KatipT m a
liftResourceT :: forall a. ResourceT IO a -> KatipT m a
$cliftResourceT :: forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> KatipT m a
MonadResource, forall (m :: * -> *) a. Monad m => m a -> KatipT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> KatipT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> KatipT m a
MonadTrans
           , MonadBase b)


instance MonadIO m => Katip (KatipT m) where
    getLogEnv :: KatipT m LogEnv
getLogEnv = forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    localLogEnv :: forall a. (LogEnv -> LogEnv) -> KatipT m a -> KatipT m a
localLogEnv LogEnv -> LogEnv
f (KatipT ReaderT LogEnv m a
m) = forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
local LogEnv -> LogEnv
f ReaderT LogEnv m a
m


instance MonadTransControl KatipT where
    type StT (KatipT) a = a
    liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run KatipT -> m a) -> KatipT m a
liftWith Run KatipT -> m a
f = forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \LogEnv
le -> Run KatipT -> m a
f forall a b. (a -> b) -> a -> b
$ \KatipT n b
t -> forall (m :: * -> *) a. LogEnv -> KatipT m a -> m a
runKatipT LogEnv
le KatipT n b
t
    restoreT :: forall (m :: * -> *) a. Monad m => m (StT KatipT a) -> KatipT m a
restoreT = forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
    {-# INLINABLE liftWith #-}
    {-# INLINABLE restoreT #-}


instance (MonadBaseControl b m) => MonadBaseControl b (KatipT m) where
  type StM ((KatipT) m) a = ComposeSt (KatipT) m a
  liftBaseWith :: forall a. (RunInBase (KatipT m) b -> b a) -> KatipT m a
liftBaseWith = forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. StM (KatipT m) a -> KatipT m a
restoreM = forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
defaultRestoreM

instance MonadUnliftIO m => MonadUnliftIO (KatipT m) where
#if MIN_VERSION_unliftio_core(0, 2, 0)
  withRunInIO :: forall b. ((forall a. KatipT m a -> IO a) -> IO b) -> KatipT m b
withRunInIO (forall a. KatipT m a -> IO a) -> IO b
inner = forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \LogEnv
le -> forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    (forall a. KatipT m a -> IO a) -> IO b
inner (forall a. m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. LogEnv -> KatipT m a -> m a
runKatipT LogEnv
le)
#else
  askUnliftIO = KatipT $
    withUnliftIO $ \u ->
      pure (UnliftIO (unliftIO u . unKatipT))
#endif

#if MIN_VERSION_base(4, 9, 0)
instance MF.MonadFail m => MF.MonadFail (KatipT m) where
    fail :: forall a. String -> KatipT m a
fail String
msg = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a. MonadFail m => String -> m a
MF.fail String
msg)
    {-# INLINE fail #-}
#endif

-------------------------------------------------------------------------------
-- | Execute 'KatipT' on a log env.
runKatipT :: LogEnv -> KatipT m a -> m a
runKatipT :: forall (m :: * -> *) a. LogEnv -> KatipT m a -> m a
runKatipT LogEnv
le (KatipT ReaderT LogEnv m a
f) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT LogEnv m a
f LogEnv
le


-------------------------------------------------------------------------------
-- | Disable all scribes for the given monadic action, then restore
-- them afterwards. Works in any Katip monad.
katipNoLogging
    :: ( Katip m
       )
    => m a
    -> m a
katipNoLogging :: forall (m :: * -> *) a. Katip m => m a -> m a
katipNoLogging = forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv (\LogEnv
le -> forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes forall a. Monoid a => a
mempty LogEnv
le)


-------------------------------------------------------------------------------
-- | Log with everything, including a source code location. This is
-- very low level and you typically can use 'logT' in its place.
logItem
    :: (A.Applicative m, LogItem a, Katip m)
    => a
    -> Namespace
    -> Maybe Loc
    -> Severity
    -> LogStr
    -> m ()
logItem :: forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
logItem a
a Namespace
ns Maybe Loc
loc Severity
sev LogStr
msg = do
    LogEnv{String
IO UTCTime
Map Text ScribeHandle
ProcessID
Environment
Namespace
_logEnvScribes :: Map Text ScribeHandle
_logEnvTimer :: IO UTCTime
_logEnvEnv :: Environment
_logEnvApp :: Namespace
_logEnvPid :: ProcessID
_logEnvHost :: String
_logEnvScribes :: LogEnv -> Map Text ScribeHandle
_logEnvTimer :: LogEnv -> IO UTCTime
_logEnvEnv :: LogEnv -> Environment
_logEnvApp :: LogEnv -> Namespace
_logEnvPid :: LogEnv -> ProcessID
_logEnvHost :: LogEnv -> String
..} <- forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
Item a -> m ()
logKatipItem forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (forall a.
Namespace
-> Environment
-> Severity
-> ThreadIdText
-> String
-> ProcessID
-> a
-> LogStr
-> UTCTime
-> Namespace
-> Maybe Loc
-> Item a
Item forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Namespace
_logEnvApp
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Environment
_logEnvEnv
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Severity
sev
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ThreadId -> ThreadIdText
mkThreadIdText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ThreadId
myThreadId)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
_logEnvHost
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessID
_logEnvPid
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure LogStr
msg
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO UTCTime
_logEnvTimer
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace
_logEnvApp forall a. Semigroup a => a -> a -> a
<> Namespace
ns)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Loc
loc)

-- | Log already constructed 'Item'. This is the lowest level function that other log*
--   functions use.
--   It can be useful when implementing centralised logging services.
logKatipItem
    :: (A.Applicative m, LogItem a, Katip m)
    => Item a
    -> m ()
logKatipItem :: forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
Item a -> m ()
logKatipItem Item a
item = do
    LogEnv{String
IO UTCTime
Map Text ScribeHandle
ProcessID
Environment
Namespace
_logEnvScribes :: Map Text ScribeHandle
_logEnvTimer :: IO UTCTime
_logEnvEnv :: Environment
_logEnvApp :: Namespace
_logEnvPid :: ProcessID
_logEnvHost :: String
_logEnvScribes :: LogEnv -> Map Text ScribeHandle
_logEnvTimer :: LogEnv -> IO UTCTime
_logEnvEnv :: LogEnv -> Environment
_logEnvApp :: LogEnv -> Namespace
_logEnvPid :: LogEnv -> ProcessID
_logEnvHost :: LogEnv -> String
..} <- forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
FT.forM_ (forall k a. Map k a -> [a]
M.elems Map Text ScribeHandle
_logEnvScribes) forall a b. (a -> b) -> a -> b
$ \ ScribeHandle {TBQueue WorkerMessage
Scribe
shChan :: TBQueue WorkerMessage
shScribe :: Scribe
shChan :: ScribeHandle -> TBQueue WorkerMessage
shScribe :: ScribeHandle -> Scribe
..} -> do
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Scribe -> PermitFunc
scribePermitItem Scribe
shScribe Item a
item) forall a b. (a -> b) -> a -> b
$
          forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically (forall a. TBQueue a -> a -> STM Bool
tryWriteTBQueue TBQueue WorkerMessage
shChan (forall a. LogItem a => Item a -> WorkerMessage
NewItem Item a
item))

-------------------------------------------------------------------------------
tryWriteTBQueue
    :: TBQueue a
    -> a
    -> STM Bool
    -- ^ Did we write?
tryWriteTBQueue :: forall a. TBQueue a -> a -> STM Bool
tryWriteTBQueue TBQueue a
q a
a = do
  Bool
full <- forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue a
q
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
full (forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue a
q a
a)
  forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
full)


-------------------------------------------------------------------------------
-- | Log with full context, but without any code location.
logF
  :: (Applicative m, LogItem a, Katip m)
  => a
  -- ^ Contextual payload for the log
  -> Namespace
  -- ^ Specific namespace of the message.
  -> Severity
  -- ^ Severity of the message
  -> LogStr
  -- ^ The log message
  -> m ()
logF :: forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Severity -> LogStr -> m ()
logF a
a Namespace
ns Severity
sev LogStr
msg = forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
logItem a
a Namespace
ns forall a. Maybe a
Nothing Severity
sev LogStr
msg



-------------------------------------------------------------------------------
-- | Perform an action while logging any exceptions that may occur.
-- Inspired by 'onException`.
--
-- >>>> logException () mempty ErrorS (error "foo")
logException
    :: (Katip m, LogItem a, MonadCatch m, Applicative m)
    => a                        -- ^ Log context
    -> Namespace                -- ^ Namespace
    -> Severity                 -- ^ Severity
    -> m b                      -- ^ Main action being run
    -> m b
logException :: forall (m :: * -> *) a b.
(Katip m, LogItem a, MonadCatch m, Applicative m) =>
a -> Namespace -> Severity -> m b -> m b
logException a
a Namespace
ns Severity
sev m b
action = m b
action forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e -> SomeException -> m ()
f SomeException
e forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
  where
    f :: SomeException -> m ()
f SomeException
e = forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Severity -> LogStr -> m ()
logF a
a Namespace
ns Severity
sev (forall a. Show a => a -> LogStr
msg SomeException
e)
    msg :: a -> LogStr
msg a
e = forall a. StringConv a Text => a -> LogStr
ls (String -> Text
T.pack String
"An exception has occurred: ") forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> LogStr
showLS a
e


-------------------------------------------------------------------------------
-- | Log a message without any payload/context or code location.
logMsg
    :: (Applicative m, Katip m)
    => Namespace
    -> Severity
    -> LogStr
    -> m ()
logMsg :: forall (m :: * -> *).
(Applicative m, Katip m) =>
Namespace -> Severity -> LogStr -> m ()
logMsg Namespace
ns Severity
sev LogStr
msg = forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Severity -> LogStr -> m ()
logF () Namespace
ns Severity
sev LogStr
msg


-- | Lift a location into an Exp.
liftLoc :: Loc -> Q Exp
liftLoc :: Loc -> Q Exp
liftLoc (Loc String
a String
b String
c (Int
d1, Int
d2) (Int
e1, Int
e2)) = [|Loc
    $(TH.lift a)
    $(TH.lift b)
    $(TH.lift c)
    ($(TH.lift d1), $(TH.lift d2))
    ($(TH.lift e1), $(TH.lift e2))
    |]


-------------------------------------------------------------------------------
-- | For use when you want to include location in your logs. This will
-- fill the 'Maybe Loc' gap in 'logF' of this module, and relies on implicit
-- callstacks when available (GHC > 7.8).
#if MIN_VERSION_base(4, 8, 0)
getLoc :: HasCallStack => Maybe Loc
getLoc :: HasCallStack => Maybe Loc
getLoc = case CallStack -> [(String, SrcLoc)]
getCallStack HasCallStack => CallStack
callStack of
  [] -> forall a. Maybe a
Nothing
  [(String, SrcLoc)]
xs -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> Loc
toLoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (String, SrcLoc) -> Bool
filterKatip [(String, SrcLoc)]
xs
  where
    filterKatip :: (String, SrcLoc) -> Bool
    filterKatip :: (String, SrcLoc) -> Bool
filterKatip (String
_, SrcLoc
srcloc) = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$
      String
"katip-" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` SrcLoc -> String
srcLocPackage SrcLoc
srcloc

    toLoc :: (String, SrcLoc) -> Loc
    toLoc :: (String, SrcLoc) -> Loc
toLoc (String
_, SrcLoc
l) = Loc {
        loc_filename :: String
loc_filename = SrcLoc -> String
srcLocFile SrcLoc
l
      , loc_package :: String
loc_package  = SrcLoc -> String
srcLocPackage SrcLoc
l
      , loc_module :: String
loc_module   = SrcLoc -> String
srcLocModule SrcLoc
l
      , loc_start :: CharPos
loc_start    = (SrcLoc -> Int
srcLocStartLine SrcLoc
l, SrcLoc -> Int
srcLocStartCol SrcLoc
l)
      , loc_end :: CharPos
loc_end      = (SrcLoc -> Int
srcLocEndLine   SrcLoc
l, SrcLoc -> Int
srcLocEndCol   SrcLoc
l)
      }
#else
getLoc :: Maybe Loc
getLoc = Nothing
#endif


-------------------------------------------------------------------------------
-- Like `getLoc`, but uses template-haskell and works with older versions of
-- the compiler (GHC 7.8 or older).
getLocTH :: ExpQ
getLocTH :: Q Exp
getLocTH = [| $(location >>= liftLoc) |]


-------------------------------------------------------------------------------
-- | 'Loc'-tagged logging when using template-haskell.
--
-- @$(logT) obj mempty InfoS "Hello world"@
logT :: ExpQ
logT :: Q Exp
logT = [| \ a ns sev msg -> logItem a ns (Just $(getLocTH)) sev msg |]


-------------------------------------------------------------------------------
-- | 'Loc'-tagged logging using 'GHC.Stack' when available.
--
-- This function does not require template-haskell as it
-- automatically uses <https://hackage.haskell.org/package/base-4.8.2.0/docs/GHC-Stack.html#v:getCallStack implicit-callstacks>
-- when the code is compiled using GHC > 7.8. Using an older version of the
-- compiler will result in the emission of a log line without any location information,
-- so be aware of it. Users using GHC <= 7.8 may want to use the template-haskell function
-- `logT` for maximum compatibility.
--
-- @logLoc obj mempty InfoS "Hello world"@
#if MIN_VERSION_base(4, 8, 0)
logLoc :: (Applicative m, LogItem a, Katip m, HasCallStack)
#else
logLoc :: (Applicative m, LogItem a, Katip m)
#endif
       => a
       -> Namespace
       -> Severity
       -> LogStr
       -> m ()
logLoc :: forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m, HasCallStack) =>
a -> Namespace -> Severity -> LogStr -> m ()
logLoc a
a Namespace
ns = forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
logItem a
a Namespace
ns HasCallStack => Maybe Loc
getLoc


-- taken from the file-location package
-- turn the TH Loc loaction information into a human readable string
-- leaving out the loc_end parameter
locationToString :: Loc -> String
locationToString :: Loc -> String
locationToString Loc
loc = (Loc -> String
loc_package Loc
loc) forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: (Loc -> String
loc_module Loc
loc) forall a. [a] -> [a] -> [a]
++
  Char
' ' forall a. a -> [a] -> [a]
: (Loc -> String
loc_filename Loc
loc) forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: (Loc -> String
line Loc
loc) forall a. [a] -> [a] -> [a]
++ Char
':' forall a. a -> [a] -> [a]
: (Loc -> String
char Loc
loc)
  where
    line :: Loc -> String
line = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_start
    char :: Loc -> String
char = forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_start