{-# 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 :: String -> Maybe a
readMay String
s = case [a
x | (a
x,String
t) <- ReadS a
forall a. Read a => ReadS a
reads String
s, (String
"",String
"") <- ReadS String
lex String
t] of
              [a
x] -> a -> Maybe a
forall a. a -> Maybe a
Just a
x
              []  -> Maybe a
forall a. Maybe a
Nothing -- no parse
              [a]
_   -> Maybe 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
(Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool) -> Eq Namespace
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
(Int -> Namespace -> ShowS)
-> (Namespace -> String)
-> ([Namespace] -> ShowS)
-> Show Namespace
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]
(Int -> ReadS Namespace)
-> ReadS [Namespace]
-> ReadPrec Namespace
-> ReadPrec [Namespace]
-> Read 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
Eq Namespace
-> (Namespace -> Namespace -> Ordering)
-> (Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Bool)
-> (Namespace -> Namespace -> Namespace)
-> (Namespace -> Namespace -> Namespace)
-> Ord 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
$cp1Ord :: Eq Namespace
Ord,(forall x. Namespace -> Rep Namespace x)
-> (forall x. Rep Namespace x -> Namespace) -> Generic Namespace
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 -> Encoding
Namespace -> Value
(Namespace -> Value)
-> (Namespace -> Encoding)
-> ([Namespace] -> Value)
-> ([Namespace] -> Encoding)
-> ToJSON Namespace
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
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,Value -> Parser [Namespace]
Value -> Parser Namespace
(Value -> Parser Namespace)
-> (Value -> Parser [Namespace]) -> FromJSON Namespace
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Namespace]
$cparseJSONList :: Value -> Parser [Namespace]
parseJSON :: Value -> Parser Namespace
$cparseJSON :: Value -> Parser Namespace
FromJSON,b -> Namespace -> Namespace
NonEmpty Namespace -> Namespace
Namespace -> Namespace -> Namespace
(Namespace -> Namespace -> Namespace)
-> (NonEmpty Namespace -> Namespace)
-> (forall b. Integral b => b -> Namespace -> Namespace)
-> Semigroup 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 :: 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
Semigroup Namespace
-> Namespace
-> (Namespace -> Namespace -> Namespace)
-> ([Namespace] -> Namespace)
-> Monoid 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
$cp1Monoid :: Semigroup Namespace
Monoid,Namespace -> Q Exp
Namespace -> Q (TExp Namespace)
(Namespace -> Q Exp)
-> (Namespace -> Q (TExp Namespace)) -> Lift Namespace
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Namespace -> Q (TExp Namespace)
$cliftTyped :: Namespace -> Q (TExp Namespace)
lift :: Namespace -> Q Exp
$clift :: Namespace -> Q Exp
TH.Lift)

instance IsString Namespace where
    fromString :: String -> Namespace
fromString String
s = [Text] -> Namespace
Namespace [String -> Text
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) = Text -> [Text] -> [Text]
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
(Environment -> Environment -> Bool)
-> (Environment -> Environment -> Bool) -> Eq Environment
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
(Int -> Environment -> ShowS)
-> (Environment -> String)
-> ([Environment] -> ShowS)
-> Show Environment
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]
(Int -> ReadS Environment)
-> ReadS [Environment]
-> ReadPrec Environment
-> ReadPrec [Environment]
-> Read 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
Eq Environment
-> (Environment -> Environment -> Ordering)
-> (Environment -> Environment -> Bool)
-> (Environment -> Environment -> Bool)
-> (Environment -> Environment -> Bool)
-> (Environment -> Environment -> Bool)
-> (Environment -> Environment -> Environment)
-> (Environment -> Environment -> Environment)
-> Ord 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
$cp1Ord :: Eq Environment
Ord,(forall x. Environment -> Rep Environment x)
-> (forall x. Rep Environment x -> Environment)
-> Generic Environment
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 -> Encoding
Environment -> Value
(Environment -> Value)
-> (Environment -> Encoding)
-> ([Environment] -> Value)
-> ([Environment] -> Encoding)
-> ToJSON Environment
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
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,Value -> Parser [Environment]
Value -> Parser Environment
(Value -> Parser Environment)
-> (Value -> Parser [Environment]) -> FromJSON Environment
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [Environment]
$cparseJSONList :: Value -> Parser [Environment]
parseJSON :: Value -> Parser Environment
$cparseJSON :: Value -> Parser Environment
FromJSON,String -> Environment
(String -> Environment) -> IsString 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
(Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool) -> Eq Severity
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
Eq Severity
-> (Severity -> Severity -> Ordering)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Bool)
-> (Severity -> Severity -> Severity)
-> (Severity -> Severity -> Severity)
-> Ord 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
$cp1Ord :: Eq Severity
Ord, Int -> Severity -> ShowS
[Severity] -> ShowS
Severity -> String
(Int -> Severity -> ShowS)
-> (Severity -> String) -> ([Severity] -> ShowS) -> Show Severity
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]
(Int -> ReadS Severity)
-> ReadS [Severity]
-> ReadPrec Severity
-> ReadPrec [Severity]
-> Read 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. Severity -> Rep Severity x)
-> (forall x. Rep Severity x -> Severity) -> Generic Severity
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]
(Severity -> Severity)
-> (Severity -> Severity)
-> (Int -> Severity)
-> (Severity -> Int)
-> (Severity -> [Severity])
-> (Severity -> Severity -> [Severity])
-> (Severity -> Severity -> [Severity])
-> (Severity -> Severity -> Severity -> [Severity])
-> Enum 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
Severity -> Severity -> Bounded Severity
forall a. a -> a -> Bounded a
maxBound :: Severity
$cmaxBound :: Severity
minBound :: Severity
$cminBound :: Severity
Bounded, Severity -> Q Exp
Severity -> Q (TExp Severity)
(Severity -> Q Exp)
-> (Severity -> Q (TExp Severity)) -> Lift Severity
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Severity -> Q (TExp Severity)
$cliftTyped :: Severity -> Q (TExp Severity)
lift :: Severity -> Q Exp
$clift :: Severity -> Q 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
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
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
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord 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
$cp1Ord :: Eq Verbosity
Ord, Int -> Verbosity -> ShowS
[Verbosity] -> ShowS
Verbosity -> String
(Int -> Verbosity -> ShowS)
-> (Verbosity -> String)
-> ([Verbosity] -> ShowS)
-> Show Verbosity
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]
(Int -> ReadS Verbosity)
-> ReadS [Verbosity]
-> ReadPrec Verbosity
-> ReadPrec [Verbosity]
-> Read 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. Verbosity -> Rep Verbosity x)
-> (forall x. Rep Verbosity x -> Verbosity) -> Generic Verbosity
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]
(Verbosity -> Verbosity)
-> (Verbosity -> Verbosity)
-> (Int -> Verbosity)
-> (Verbosity -> Int)
-> (Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> [Verbosity])
-> (Verbosity -> Verbosity -> Verbosity -> [Verbosity])
-> Enum 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
Verbosity -> Verbosity -> Bounded Verbosity
forall a. a -> a -> Bounded a
maxBound :: Verbosity
$cmaxBound :: Verbosity
minBound :: Verbosity
$cminBound :: Verbosity
Bounded, Verbosity -> Q Exp
Verbosity -> Q (TExp Verbosity)
(Verbosity -> Q Exp)
-> (Verbosity -> Q (TExp Verbosity)) -> Lift Verbosity
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Verbosity -> Q (TExp Verbosity)
$cliftTyped :: Verbosity -> Q (TExp Verbosity)
lift :: Verbosity -> Q Exp
$clift :: Verbosity -> Q 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 = Text -> Maybe Severity
forall a. (Eq a, IsString a) => a -> Maybe Severity
go (Text -> Maybe Severity)
-> (Text -> Text) -> Text -> Maybe Severity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.toLower
  where
    go :: a -> Maybe Severity
go a
"debug"     = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
DebugS
    go a
"info"      = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
InfoS
    go a
"notice"    = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
NoticeS
    go a
"warning"   = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
WarningS
    go a
"error"     = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
ErrorS
    go a
"critical"  = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
CriticalS
    go a
"alert"     = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
AlertS
    go a
"emergency" = Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
EmergencyS
    go a
_           = Maybe Severity
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 = String -> (Text -> Parser Severity) -> Value -> Parser Severity
forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"Severity" Text -> Parser 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  -> Severity -> m Severity
forall (m :: * -> *) a. Monad m => a -> m a
return Severity
x
          Maybe Severity
Nothing -> String -> m Severity
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m Severity) -> String -> m Severity
forall a b. (a -> b) -> a -> b
$ String
"Invalid Severity " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
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 (Text -> Value) -> Text -> Value
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 = String -> (Text -> Parser Verbosity) -> Value -> Parser Verbosity
forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"Verbosity" ((Text -> Parser Verbosity) -> Value -> Parser Verbosity)
-> (Text -> Parser Verbosity) -> Value -> Parser Verbosity
forall a b. (a -> b) -> a -> b
$ \Text
s -> case Text
s of
      Text
"V0" -> Verbosity -> Parser Verbosity
forall (m :: * -> *) a. Monad m => a -> m a
return Verbosity
V0
      Text
"V1" -> Verbosity -> Parser Verbosity
forall (m :: * -> *) a. Monad m => a -> m a
return Verbosity
V1
      Text
"V2" -> Verbosity -> Parser Verbosity
forall (m :: * -> *) a. Monad m => a -> m a
return Verbosity
V2
      Text
"V3" -> Verbosity -> Parser Verbosity
forall (m :: * -> *) a. Monad m => a -> m a
return Verbosity
V3
      Text
_    -> String -> Parser Verbosity
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Verbosity) -> String -> Parser Verbosity
forall a b. (a -> b) -> a -> b
$ String
"Invalid Verbosity " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
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. LogStr -> Rep LogStr x)
-> (forall x. Rep LogStr x -> LogStr) -> Generic LogStr
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
(Int -> LogStr -> ShowS)
-> (LogStr -> String) -> ([LogStr] -> ShowS) -> Show LogStr
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
(LogStr -> LogStr -> Bool)
-> (LogStr -> LogStr -> Bool) -> Eq LogStr
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 (Builder -> LogStr) -> (String -> Builder) -> String -> 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 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b)


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


instance FromJSON LogStr where
    parseJSON :: Value -> Parser LogStr
parseJSON = String -> (Text -> Parser LogStr) -> Value -> Parser LogStr
forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"LogStr" Text -> Parser LogStr
parseLogStr
      where
        parseLogStr :: Text -> Parser LogStr
parseLogStr = LogStr -> Parser LogStr
forall (m :: * -> *) a. Monad m => a -> m a
return (LogStr -> Parser LogStr)
-> (Text -> LogStr) -> Text -> Parser LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LogStr
LogStr (Builder -> LogStr) -> (Text -> Builder) -> Text -> 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 :: a -> LogStr
logStr a
t = Builder -> LogStr
LogStr (Text -> Builder
B.fromText (Text -> Builder) -> Text -> Builder
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a b. StringConv a b => a -> b
toS a
t)


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


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


-------------------------------------------------------------------------------
newtype ThreadIdText = ThreadIdText {
      ThreadIdText -> Text
getThreadIdText :: Text
    } deriving ([ThreadIdText] -> Encoding
[ThreadIdText] -> Value
ThreadIdText -> Encoding
ThreadIdText -> Value
(ThreadIdText -> Value)
-> (ThreadIdText -> Encoding)
-> ([ThreadIdText] -> Value)
-> ([ThreadIdText] -> Encoding)
-> ToJSON ThreadIdText
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
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, Value -> Parser [ThreadIdText]
Value -> Parser ThreadIdText
(Value -> Parser ThreadIdText)
-> (Value -> Parser [ThreadIdText]) -> FromJSON ThreadIdText
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [ThreadIdText]
$cparseJSONList :: Value -> Parser [ThreadIdText]
parseJSON :: Value -> Parser ThreadIdText
$cparseJSON :: Value -> Parser ThreadIdText
FromJSON, Int -> ThreadIdText -> ShowS
[ThreadIdText] -> ShowS
ThreadIdText -> String
(Int -> ThreadIdText -> ShowS)
-> (ThreadIdText -> String)
-> ([ThreadIdText] -> ShowS)
-> Show ThreadIdText
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
(ThreadIdText -> ThreadIdText -> Bool)
-> (ThreadIdText -> ThreadIdText -> Bool) -> Eq ThreadIdText
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
Eq ThreadIdText
-> (ThreadIdText -> ThreadIdText -> Ordering)
-> (ThreadIdText -> ThreadIdText -> Bool)
-> (ThreadIdText -> ThreadIdText -> Bool)
-> (ThreadIdText -> ThreadIdText -> Bool)
-> (ThreadIdText -> ThreadIdText -> Bool)
-> (ThreadIdText -> ThreadIdText -> ThreadIdText)
-> (ThreadIdText -> ThreadIdText -> ThreadIdText)
-> Ord 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
$cp1Ord :: Eq ThreadIdText
Ord)


mkThreadIdText :: ThreadId -> ThreadIdText
mkThreadIdText :: ThreadId -> ThreadIdText
mkThreadIdText = Text -> ThreadIdText
ThreadIdText (Text -> ThreadIdText)
-> (ThreadId -> Text) -> ThreadId -> ThreadIdText
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> Text
stripPrefix' Text
"ThreadId " (Text -> Text) -> (ThreadId -> Text) -> ThreadId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (ThreadId -> String) -> ThreadId -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> String
forall a. Show a => a -> String
show
  where
    stripPrefix' :: Text -> Text -> Text
stripPrefix' Text
pfx Text
t = Text -> Maybe Text -> Text
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 {
      Item a -> Namespace
_itemApp       :: Namespace
    , Item a -> Environment
_itemEnv       :: Environment
    , Item a -> Severity
_itemSeverity  :: Severity
    , Item a -> ThreadIdText
_itemThread    :: ThreadIdText
    , Item a -> String
_itemHost      :: HostName
    , Item a -> ProcessID
_itemProcess   :: ProcessID
    , Item a -> a
_itemPayload   :: a
    , Item a -> LogStr
_itemMessage   :: LogStr
    , Item a -> UTCTime
_itemTime      :: UTCTime
    , Item a -> Namespace
_itemNamespace :: Namespace
    , Item a -> Maybe Loc
_itemLoc       :: Maybe Loc
    } deriving ((forall x. Item a -> Rep (Item a) x)
-> (forall x. Rep (Item a) x -> Item a) -> Generic (Item a)
forall x. Rep (Item a) x -> Item a
forall x. Item a -> Rep (Item a) x
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, a -> Item b -> Item a
(a -> b) -> Item a -> Item b
(forall a b. (a -> b) -> Item a -> Item b)
-> (forall a b. a -> Item b -> Item a) -> Functor Item
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
<$ :: a -> Item b -> Item a
$c<$ :: forall a b. a -> Item b -> Item a
fmap :: (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 = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
FT.and [ Item a -> Namespace
forall a. Item a -> Namespace
_itemApp Item a
a Namespace -> Namespace -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> Namespace
forall a. Item a -> Namespace
_itemApp Item a
b
                    , Item a -> Environment
forall a. Item a -> Environment
_itemEnv Item a
a Environment -> Environment -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> Environment
forall a. Item a -> Environment
_itemEnv Item a
b
                    , Item a -> Severity
forall a. Item a -> Severity
_itemSeverity Item a
a Severity -> Severity -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> Severity
forall a. Item a -> Severity
_itemSeverity Item a
b
                    , Item a -> ThreadIdText
forall a. Item a -> ThreadIdText
_itemThread Item a
a ThreadIdText -> ThreadIdText -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> ThreadIdText
forall a. Item a -> ThreadIdText
_itemThread Item a
b
                    , Item a -> String
forall a. Item a -> String
_itemHost Item a
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> String
forall a. Item a -> String
_itemHost Item a
b
                    , Item a -> ProcessID
forall a. Item a -> ProcessID
_itemProcess Item a
a ProcessID -> ProcessID -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> ProcessID
forall a. Item a -> ProcessID
_itemProcess Item a
b
                    , Item a -> a
forall a. Item a -> a
_itemPayload Item a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> a
forall a. Item a -> a
_itemPayload Item a
b
                    , Item a -> LogStr
forall a. Item a -> LogStr
_itemMessage Item a
a LogStr -> LogStr -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> LogStr
forall a. Item a -> LogStr
_itemMessage Item a
b
                    , Item a -> UTCTime
forall a. Item a -> UTCTime
_itemTime Item a
a UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> UTCTime
forall a. Item a -> UTCTime
_itemTime Item a
b
                    , Item a -> Namespace
forall a. Item a -> Namespace
_itemNamespace Item a
a Namespace -> Namespace -> Bool
forall a. Eq a => a -> a -> Bool
== Item a -> Namespace
forall a. Item a -> Namespace
_itemNamespace Item a
b
                    , case (Item a -> Maybe Loc
forall a. Item a -> Maybe Loc
_itemLoc Item a
a, Item a -> Maybe Loc
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) -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
FT.and [ Loc -> String
loc_filename Loc
l1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Loc -> String
loc_filename Loc
l2
                                                     , Loc -> String
loc_package Loc
l1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Loc -> String
loc_package Loc
l2
                                                     , Loc -> String
loc_module Loc
l1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== Loc -> String
loc_module Loc
l2
                                                     , Loc -> CharPos
loc_start Loc
l1 CharPos -> CharPos -> Bool
forall a. Eq a => a -> a -> Bool
== Loc -> CharPos
loc_start Loc
l2
                                                     , Loc -> CharPos
loc_end Loc
l1 CharPos -> CharPos -> Bool
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11) ( String -> ShowS
showString String
"Item {"
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Namespace -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemApp" Namespace
_itemApp
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Environment -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemEnv" Environment
_itemEnv
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Severity -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemSeverity" Severity
_itemSeverity
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ThreadIdText -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemThread" ThreadIdText
_itemThread
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemHost" String
_itemHost
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProcessID -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemProcess" ProcessID
_itemProcess
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> a -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemPayload" a
_itemPayload
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LogStr -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemMessage" LogStr
_itemMessage
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> UTCTime -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemTime" UTCTime
_itemTime
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Namespace -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"_itemNamespace" Namespace
_itemNamespace
                                               ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"_itemLoc = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe LocShow -> ShowS
forall a. Show a => a -> ShowS
shows (Loc -> LocShow
LocShow (Loc -> LocShow) -> Maybe Loc -> Maybe LocShow
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Loc
_itemLoc)
                                               ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
v ShowS -> ShowS -> ShowS
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11) ( String -> ShowS
showString String
"Loc {"
                                                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"loc_filename" String
loc_filename
                                                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"loc_package" String
loc_package
                                                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"loc_module" String
loc_module
                                                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> CharPos -> ShowS
forall a. Show a => String -> a -> ShowS
field String
"loc_start" CharPos
loc_start
                                                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"loc_end = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPos -> ShowS
forall a. Show a => a -> ShowS
shows CharPos
loc_end
                                                        ShowS -> ShowS -> ShowS
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 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" = " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
v ShowS -> ShowS -> ShowS
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
      [ Text
"app" Text -> Namespace -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Namespace
_itemApp
      , Text
"env" Text -> Environment -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Environment
_itemEnv
      , Text
"sev" Text -> Severity -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Severity
_itemSeverity
      , Text
"thread" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= ThreadIdText -> Text
getThreadIdText ThreadIdText
_itemThread
      , Text
"host" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= String
_itemHost
      , Text
"pid" Text -> ProcessIDJs -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= ProcessID -> ProcessIDJs
ProcessIDJs ProcessID
_itemProcess
      , Text
"data" Text -> a -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= a
_itemPayload
      , Text
"msg" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= (Builder -> Text
B.toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ LogStr -> Builder
unLogStr LogStr
_itemMessage)
      , Text
"at" Text -> UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= UTCTime
_itemTime
      , Text
"ns" Text -> Namespace -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Namespace
_itemNamespace
      , Text
"loc" Text -> Maybe LocJs -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= (Loc -> LocJs) -> Maybe Loc -> Maybe LocJs
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
      [ Text
"loc_fn" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= String
fn
      , Text
"loc_pkg" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= String
p
      , Text
"loc_mod" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= String
m
      , Text
"loc_ln" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Int
l
      , Text
"loc_col" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= Int
c
      ]


instance FromJSON LocJs where
    parseJSON :: Value -> Parser LocJs
parseJSON = String -> (Object -> Parser LocJs) -> Value -> Parser LocJs
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 Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"loc_fn"
          String
p <- Object
o Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"loc_pkg"
          String
m <- Object
o Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"loc_mod"
          Int
l <- Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"loc_ln"
          Int
c <- Object
o Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"loc_col"
          LocJs -> Parser LocJs
forall (m :: * -> *) a. Monad m => a -> m a
return (LocJs -> Parser LocJs) -> LocJs -> Parser LocJs
forall a b. (a -> b) -> a -> b
$ Loc -> LocJs
LocJs (Loc -> LocJs) -> Loc -> 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 = String -> (Object -> Parser (Item a)) -> Value -> Parser (Item a)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
A.withObject String
"Item" Object -> Parser (Item a)
forall a. FromJSON a => Object -> Parser (Item a)
parseItem
      where
        parseItem :: Object -> Parser (Item a)
parseItem Object
o = Namespace
-> Environment
-> Severity
-> ThreadIdText
-> String
-> ProcessID
-> a
-> LogStr
-> UTCTime
-> Namespace
-> Maybe Loc
-> Item a
forall a.
Namespace
-> Environment
-> Severity
-> ThreadIdText
-> String
-> ProcessID
-> a
-> LogStr
-> UTCTime
-> Namespace
-> Maybe Loc
-> Item a
Item
          (Namespace
 -> Environment
 -> Severity
 -> ThreadIdText
 -> String
 -> ProcessID
 -> a
 -> LogStr
 -> UTCTime
 -> Namespace
 -> Maybe Loc
 -> Item a)
-> Parser Namespace
-> Parser
     (Environment
      -> Severity
      -> ThreadIdText
      -> String
      -> ProcessID
      -> a
      -> LogStr
      -> UTCTime
      -> Namespace
      -> Maybe Loc
      -> Item a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser Namespace
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"app"
          Parser
  (Environment
   -> Severity
   -> ThreadIdText
   -> String
   -> ProcessID
   -> a
   -> LogStr
   -> UTCTime
   -> Namespace
   -> Maybe Loc
   -> Item a)
-> Parser Environment
-> Parser
     (Severity
      -> ThreadIdText
      -> String
      -> ProcessID
      -> a
      -> LogStr
      -> UTCTime
      -> Namespace
      -> Maybe Loc
      -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Environment
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"env"
          Parser
  (Severity
   -> ThreadIdText
   -> String
   -> ProcessID
   -> a
   -> LogStr
   -> UTCTime
   -> Namespace
   -> Maybe Loc
   -> Item a)
-> Parser Severity
-> Parser
     (ThreadIdText
      -> String
      -> ProcessID
      -> a
      -> LogStr
      -> UTCTime
      -> Namespace
      -> Maybe Loc
      -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Severity
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"sev"
          Parser
  (ThreadIdText
   -> String
   -> ProcessID
   -> a
   -> LogStr
   -> UTCTime
   -> Namespace
   -> Maybe Loc
   -> Item a)
-> Parser ThreadIdText
-> Parser
     (String
      -> ProcessID
      -> a
      -> LogStr
      -> UTCTime
      -> Namespace
      -> Maybe Loc
      -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser ThreadIdText
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"thread"
          Parser
  (String
   -> ProcessID
   -> a
   -> LogStr
   -> UTCTime
   -> Namespace
   -> Maybe Loc
   -> Item a)
-> Parser String
-> Parser
     (ProcessID
      -> a -> LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"host"
          Parser
  (ProcessID
   -> a -> LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
-> Parser ProcessID
-> Parser
     (a -> LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ProcessIDJs -> ProcessID
getProcessIDJs (ProcessIDJs -> ProcessID)
-> Parser ProcessIDJs -> Parser ProcessID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser ProcessIDJs
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"pid")
          Parser (a -> LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
-> Parser a
-> Parser (LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser a
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"data"
          Parser (LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
-> Parser LogStr
-> Parser (UTCTime -> Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser LogStr
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"msg"
          Parser (UTCTime -> Namespace -> Maybe Loc -> Item a)
-> Parser UTCTime -> Parser (Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser UTCTime
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"at"
          Parser (Namespace -> Maybe Loc -> Item a)
-> Parser Namespace -> Parser (Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Text -> Parser Namespace
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"ns"
          Parser (Maybe Loc -> Item a)
-> Parser (Maybe Loc) -> Parser (Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ((LocJs -> Loc) -> Maybe LocJs -> Maybe Loc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LocJs -> Loc
getLocJs (Maybe LocJs -> Maybe Loc)
-> Parser (Maybe LocJs) -> Parser (Maybe Loc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Text -> Parser (Maybe LocJs)
forall a. FromJSON a => Object -> Text -> Parser a
A..: Text
"loc")


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


textToProcessID :: Text -> Maybe ProcessID
textToProcessID :: Text -> Maybe ProcessID
textToProcessID = String -> Maybe ProcessID
forall a. Read a => String -> Maybe a
readMay (String -> Maybe ProcessID)
-> (Text -> String) -> Text -> Maybe ProcessID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
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 = String
-> (Text -> Parser ProcessIDJs) -> Value -> Parser ProcessIDJs
forall a. String -> (Text -> Parser a) -> Value -> Parser a
A.withText String
"ProcessID" Text -> Parser ProcessIDJs
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  -> ProcessIDJs -> m ProcessIDJs
forall (m :: * -> *) a. Monad m => a -> m a
return (ProcessIDJs -> m ProcessIDJs) -> ProcessIDJs -> m ProcessIDJs
forall a b. (a -> b) -> a -> b
$ ProcessID -> ProcessIDJs
ProcessIDJs ProcessID
p
          Maybe ProcessID
Nothing -> String -> m ProcessIDJs
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ProcessIDJs) -> String -> m ProcessIDJs
forall a b. (a -> b) -> a -> b
$ String
"Invalid ProcessIDJs " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
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
(Int -> PayloadSelection -> ShowS)
-> (PayloadSelection -> String)
-> ([PayloadSelection] -> ShowS)
-> Show PayloadSelection
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
(PayloadSelection -> PayloadSelection -> Bool)
-> (PayloadSelection -> PayloadSelection -> Bool)
-> Eq PayloadSelection
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 [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
bs)


instance Monoid PayloadSelection where
    mempty :: PayloadSelection
mempty = [Text] -> PayloadSelection
SomeKeys []
    mappend :: PayloadSelection -> PayloadSelection -> PayloadSelection
mappend = PayloadSelection -> PayloadSelection -> PayloadSelection
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) = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [Text]
a Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Text] -> Set Text
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 a -> Value
forall a. ToJSON a => a -> Value
toJSON a
v of
      A.Object Object
o -> Object
o
      Value
_          -> Object
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 ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ ((Text, AnyLogPayload) -> Pair)
-> [(Text, AnyLogPayload)] -> [Pair]
forall a b. (a -> b) -> [a] -> [b]
map (Text, AnyLogPayload) -> Pair
forall p. KeyValue p => (Text, AnyLogPayload) -> p
go [(Text, AnyLogPayload)]
as'
      where go :: (Text, AnyLogPayload) -> p
go (Text
k, AnyLogPayload a
v) = Text
k Text -> a -> p
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
A..= a
v
            as' :: [(Text, AnyLogPayload)]
as' = (Text, AnyLogPayload) -> (Text, AnyLogPayload)
forall a. a -> a
toKey ((Text, AnyLogPayload) -> (Text, AnyLogPayload))
-> [(Text, AnyLogPayload)] -> [(Text, AnyLogPayload)]
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 = first K.fromText
#else
toKey :: a -> a
toKey :: a -> a
toKey = a -> a
forall a. a -> a
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 [(Text, AnyLogPayload)]
-> [(Text, AnyLogPayload)] -> [(Text, AnyLogPayload)]
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 = SimpleLogPayload -> SimpleLogPayload -> SimpleLogPayload
forall a. Semigroup a => a -> a -> a
(<>)


-------------------------------------------------------------------------------
-- | Construct a simple log from any JSON item.
sl :: ToJSON a => Text -> a -> SimpleLogPayload
sl :: Text -> a -> SimpleLogPayload
sl Text
a a
b = [(Text, AnyLogPayload)] -> SimpleLogPayload
SimpleLogPayload [(Text
a, a -> AnyLogPayload
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 :: Verbosity -> a -> Object
payloadObject Verbosity
verb a
a = case (Verbosity -> PayloadSelection) -> [Verbosity] -> PayloadSelection
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
FT.foldMap ((Verbosity -> a -> PayloadSelection)
-> a -> Verbosity -> PayloadSelection
forall a b c. (a -> b -> c) -> b -> a -> c
flip Verbosity -> a -> PayloadSelection
forall a. LogItem a => Verbosity -> a -> PayloadSelection
payloadKeys a
a) [(Verbosity
V0)..Verbosity
verb] of
    PayloadSelection
AllKeys     -> a -> Object
forall a. ToObject a => a -> Object
toObject a
a
    SomeKeys [Text]
ks -> [Text] -> Object -> Object
forall v. [Text] -> HashMap Text v -> HashMap Text v
filterElems [Text]
ks (Object -> Object) -> Object -> Object
forall a b. (a -> b) -> a -> b
$ a -> Object
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 ks = KM.filterWithKey (\ k _ -> K.toText k `FT.elem` ks)
#else
filterElems :: [Text] -> HM.HashMap Text v -> HM.HashMap Text v
filterElems :: [Text] -> HashMap Text v -> HashMap Text v
filterElems [Text]
ks = (Text -> v -> Bool) -> HashMap Text v -> HashMap Text v
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HM.filterWithKey (\ Text
k v
_ -> Text
k Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`FT.elem` [Text]
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 :: Verbosity -> Item a -> Value
itemJson Verbosity
verb Item a
a = Item Object -> Value
forall a. ToJSON a => a -> Value
toJSON (Item Object -> Value) -> Item Object -> Value
forall a b. (a -> b) -> a -> b
$ Item a
a Item a -> (Item a -> Item Object) -> Item Object
forall a b. a -> (a -> b) -> b
& (a -> Identity Object) -> Item a -> Identity (Item Object)
forall a a. Lens (Item a) (Item a) a a
itemPayload ((a -> Identity Object) -> Item a -> Identity (Item Object))
-> (a -> Object) -> Item a -> Item Object
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Verbosity -> a -> Object
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 -> (Bool -> Bool -> Bool) -> IO Bool -> IO Bool -> IO Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(&&) (Item a -> IO Bool
PermitFunc
f1 Item a
a) (Item a -> IO Bool
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 -> (Bool -> Bool -> Bool) -> IO Bool -> IO Bool -> IO Bool
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 Bool -> Bool -> Bool
(||) (Item a -> IO Bool
PermitFunc
f1 Item a
a) (Item a -> IO Bool
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 :: m Bool -> m () -> m ()
whenM m Bool
mbool = m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
(>>=) m Bool
mbool ((Bool -> m ()) -> m ()) -> (m () -> Bool -> m ()) -> m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> m () -> m ()) -> m () -> Bool -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Bool -> m () -> m ()
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 -> IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Item a -> IO Bool
PermitFunc
permitA Item a
item) (Item a -> IO ()
forall a. LogItem a => Item a -> IO ()
pushA Item a
item)
                  IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Item a -> IO Bool
PermitFunc
permitB Item a
item) (Item a -> IO ()
forall a. LogItem a => Item a -> IO ()
pushB Item a
item)
           )
           (IO ()
finA IO () -> IO () -> IO ()
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 (IO () -> Item a -> IO ()
forall a b. a -> b -> a
const (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())) (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Severity -> Item a -> IO Bool
forall (m :: * -> *) a. Monad m => Severity -> Item a -> m Bool
permitItem Severity
DebugS)
    mappend :: Scribe -> Scribe -> Scribe
mappend = Scribe -> Scribe -> Scribe
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 :: Severity -> Item a -> m Bool
permitItem Severity
sev Item a
item = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Item a -> Severity
forall a. Item a -> Severity
_itemSeverity Item a
item Severity -> Severity -> Bool
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
  (String
 -> ProcessID
 -> Namespace
 -> Environment
 -> IO UTCTime
 -> Map Text ScribeHandle
 -> LogEnv)
-> IO String
-> IO
     (ProcessID
      -> Namespace
      -> Environment
      -> IO UTCTime
      -> Map Text ScribeHandle
      -> LogEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHostName
  IO
  (ProcessID
   -> Namespace
   -> Environment
   -> IO UTCTime
   -> Map Text ScribeHandle
   -> LogEnv)
-> IO ProcessID
-> IO
     (Namespace
      -> Environment -> IO UTCTime -> Map Text ScribeHandle -> LogEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO ProcessID
getProcessID
  IO
  (Namespace
   -> Environment -> IO UTCTime -> Map Text ScribeHandle -> LogEnv)
-> IO Namespace
-> IO
     (Environment -> IO UTCTime -> Map Text ScribeHandle -> LogEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Namespace -> IO Namespace
forall (f :: * -> *) a. Applicative f => a -> f a
pure Namespace
an
  IO (Environment -> IO UTCTime -> Map Text ScribeHandle -> LogEnv)
-> IO Environment
-> IO (IO UTCTime -> Map Text ScribeHandle -> LogEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Environment -> IO Environment
forall (f :: * -> *) a. Applicative f => a -> f a
pure Environment
env
  IO (IO UTCTime -> Map Text ScribeHandle -> LogEnv)
-> IO (IO UTCTime) -> IO (Map Text ScribeHandle -> LogEnv)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UpdateSettings UTCTime -> IO (IO UTCTime)
forall a. UpdateSettings a -> IO (IO a)
mkAutoUpdate UpdateSettings ()
defaultUpdateSettings { updateAction :: IO UTCTime
updateAction = IO UTCTime
getCurrentTime, updateFreq :: Int
updateFreq = Int
1000 }
  IO (Map Text ScribeHandle -> LogEnv)
-> IO (Map Text ScribeHandle) -> IO LogEnv
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Map Text ScribeHandle -> IO (Map Text ScribeHandle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Map Text ScribeHandle
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 <- STM (TBQueue WorkerMessage) -> IO (TBQueue WorkerMessage)
forall a. STM a -> IO a
atomically (Natural -> STM (TBQueue WorkerMessage)
forall a. Natural -> STM (TBQueue a)
BQ.newTBQueue (Int -> Natural
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
        STM () -> IO ()
forall a. STM a -> IO a
atomically (TBQueue WorkerMessage -> WorkerMessage -> STM ()
forall a. TBQueue a -> a -> STM ()
BQ.writeTBQueue TBQueue WorkerMessage
queue WorkerMessage
PoisonPill)
        -- wait for our worker to finish final write
        IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Async () -> IO (Either SomeException ())
forall a. Async a -> IO (Either SomeException a)
Async.waitCatch Async ()
worker)
        -- wait for scribe to finish final write
        IO () -> IO ()
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
  LogEnv -> IO LogEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (LogEnv
le LogEnv -> (LogEnv -> LogEnv) -> LogEnv
forall a b. a -> (a -> b) -> b
& (Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
-> LogEnv -> Identity LogEnv
Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes ((Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
 -> LogEnv -> Identity LogEnv)
-> (Map Text ScribeHandle -> Map Text ScribeHandle)
-> LogEnv
-> LogEnv
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text
-> ScribeHandle -> Map Text ScribeHandle -> Map Text ScribeHandle
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 = IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async IO ()
go
  where
    go :: IO ()
go = do
      WorkerMessage
newCmd <- STM WorkerMessage -> IO WorkerMessage
forall a. STM a -> IO a
atomically (TBQueue WorkerMessage -> STM WorkerMessage
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.
          IO (Either SomeException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny (Item a -> IO ()
forall a. LogItem a => Item a -> IO ()
write Item a
a))
          IO ()
go
        WorkerMessage
PoisonPill -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-------------------------------------------------------------------------------
data ScribeSettings = ScribeSettings {
      ScribeSettings -> Int
_scribeBufferSize :: Int
    }
  deriving (Int -> ScribeSettings -> ShowS
[ScribeSettings] -> ShowS
ScribeSettings -> String
(Int -> ScribeSettings -> ShowS)
-> (ScribeSettings -> String)
-> ([ScribeSettings] -> ShowS)
-> Show ScribeSettings
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
(ScribeSettings -> ScribeSettings -> Bool)
-> (ScribeSettings -> ScribeSettings -> Bool) -> Eq ScribeSettings
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 =  (Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
-> LogEnv -> Identity LogEnv
Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes ((Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
 -> LogEnv -> Identity LogEnv)
-> (Map Text ScribeHandle -> Map Text ScribeHandle)
-> LogEnv
-> LogEnv
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Map Text ScribeHandle -> Map Text ScribeHandle
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 = (Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
-> LogEnv -> Identity LogEnv
Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes ((Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
 -> LogEnv -> Identity LogEnv)
-> Map Text ScribeHandle -> LogEnv -> LogEnv
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Text ScribeHandle
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
  IO () -> (ScribeHandle -> IO ()) -> Maybe ScribeHandle -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Scribe -> IO ()
scribeFinalizer (Scribe -> IO ())
-> (ScribeHandle -> Scribe) -> ScribeHandle -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScribeHandle -> Scribe
shScribe) (Text -> Map Text ScribeHandle -> Maybe ScribeHandle
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
nm (LogEnv -> Map Text ScribeHandle
_logEnvScribes LogEnv
le))
  LogEnv -> IO LogEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (LogEnv
le LogEnv -> (LogEnv -> LogEnv) -> LogEnv
forall a b. a -> (a -> b) -> b
& (Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
-> LogEnv -> Identity LogEnv
Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes ((Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
 -> LogEnv -> Identity LogEnv)
-> (Map Text ScribeHandle -> Map Text ScribeHandle)
-> LogEnv
-> LogEnv
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Map Text ScribeHandle -> Map Text ScribeHandle
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 = [IO LogEnv -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Text -> LogEnv -> IO LogEnv
closeScribe Text
k LogEnv
le) | Text
k <- Map Text ScribeHandle -> [Text]
forall k a. Map k a -> [k]
M.keys (LogEnv -> Map Text ScribeHandle
_logEnvScribes LogEnv
le)]
  (IO () -> IO () -> IO ()) -> IO () -> [IO ()] -> IO ()
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
FT.foldr IO () -> IO () -> IO ()
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
finally (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [IO ()]
actions
  LogEnv -> IO LogEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (LogEnv
le LogEnv -> (LogEnv -> LogEnv) -> LogEnv
forall a b. a -> (a -> b) -> b
& (Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
-> LogEnv -> Identity LogEnv
Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes ((Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
 -> LogEnv -> Identity LogEnv)
-> Map Text ScribeHandle -> LogEnv -> LogEnv
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Text ScribeHandle
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 = m LogEnv -> ReaderT s m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> ReaderT s m a -> ReaderT s m a
localLogEnv = (m a -> m a) -> ReaderT s m a -> ReaderT s m a
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT ((m a -> m a) -> ReaderT s m a -> ReaderT s m a)
-> ((LogEnv -> LogEnv) -> m a -> m a)
-> (LogEnv -> LogEnv)
-> ReaderT s m a
-> ReaderT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m a -> m a
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 = m LogEnv -> ExceptT s m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> ExceptT s m a -> ExceptT s m a
localLogEnv = (m (Either s a) -> m (Either s a))
-> ExceptT s m a -> ExceptT s m a
forall (m :: * -> *) e a (n :: * -> *) e' b.
(m (Either e a) -> n (Either e' b))
-> ExceptT e m a -> ExceptT e' n b
mapExceptT ((m (Either s a) -> m (Either s a))
 -> ExceptT s m a -> ExceptT s m a)
-> ((LogEnv -> LogEnv) -> m (Either s a) -> m (Either s a))
-> (LogEnv -> LogEnv)
-> ExceptT s m a
-> ExceptT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m (Either s a) -> m (Either s a)
forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance Katip m => Katip (MaybeT m) where
    getLogEnv :: MaybeT m LogEnv
getLogEnv = m LogEnv -> MaybeT m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> MaybeT m a -> MaybeT m a
localLogEnv = (m (Maybe a) -> m (Maybe a)) -> MaybeT m a -> MaybeT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m (Maybe a) -> n (Maybe b)) -> MaybeT m a -> MaybeT n b
mapMaybeT ((m (Maybe a) -> m (Maybe a)) -> MaybeT m a -> MaybeT m a)
-> ((LogEnv -> LogEnv) -> m (Maybe a) -> m (Maybe a))
-> (LogEnv -> LogEnv)
-> MaybeT m a
-> MaybeT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m (Maybe a) -> m (Maybe a)
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 = m LogEnv -> StateT s m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> StateT s m a -> StateT s m a
localLogEnv = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
mapStateT ((m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a)
-> ((LogEnv -> LogEnv) -> m (a, s) -> m (a, s))
-> (LogEnv -> LogEnv)
-> StateT s m a
-> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m (a, s) -> m (a, s)
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 = m LogEnv -> RWST r w s m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> RWST r w s m a -> RWST r w s m a
localLogEnv = (m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a
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 ((m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a)
-> ((LogEnv -> LogEnv) -> m (a, s, w) -> m (a, s, w))
-> (LogEnv -> LogEnv)
-> RWST r w s m a
-> RWST r w s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m (a, s, w) -> m (a, s, w)
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 = m LogEnv -> RWST r w s m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> RWST r w s m a -> RWST r w s m a
localLogEnv = (m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a
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 ((m (a, s, w) -> m (a, s, w)) -> RWST r w s m a -> RWST r w s m a)
-> ((LogEnv -> LogEnv) -> m (a, s, w) -> m (a, s, w))
-> (LogEnv -> LogEnv)
-> RWST r w s m a
-> RWST r w s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m (a, s, w) -> m (a, s, w)
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 = m LogEnv -> StateT s m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> StateT s m a -> StateT s m a
localLogEnv = (m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a
forall (m :: * -> *) a s (n :: * -> *) b.
(m (a, s) -> n (b, s)) -> StateT s m a -> StateT s n b
Strict.mapStateT ((m (a, s) -> m (a, s)) -> StateT s m a -> StateT s m a)
-> ((LogEnv -> LogEnv) -> m (a, s) -> m (a, s))
-> (LogEnv -> LogEnv)
-> StateT s m a
-> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m (a, s) -> m (a, s)
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 = m LogEnv -> WriterT s m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> WriterT s m a -> WriterT s m a
localLogEnv = (m (a, s) -> m (a, s)) -> WriterT s m a -> WriterT s m a
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
mapWriterT ((m (a, s) -> m (a, s)) -> WriterT s m a -> WriterT s m a)
-> ((LogEnv -> LogEnv) -> m (a, s) -> m (a, s))
-> (LogEnv -> LogEnv)
-> WriterT s m a
-> WriterT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m (a, s) -> m (a, s)
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 = m LogEnv -> WriterT s m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> WriterT s m a -> WriterT s m a
localLogEnv = (m (a, s) -> m (a, s)) -> WriterT s m a -> WriterT s m a
forall (m :: * -> *) a w (n :: * -> *) b w'.
(m (a, w) -> n (b, w')) -> WriterT w m a -> WriterT w' n b
Strict.mapWriterT ((m (a, s) -> m (a, s)) -> WriterT s m a -> WriterT s m a)
-> ((LogEnv -> LogEnv) -> m (a, s) -> m (a, s))
-> (LogEnv -> LogEnv)
-> WriterT s m a
-> WriterT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m (a, s) -> m (a, s)
forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv


instance (Katip m) => Katip (ResourceT m) where
    getLogEnv :: ResourceT m LogEnv
getLogEnv = m LogEnv -> ResourceT m LogEnv
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    localLogEnv :: (LogEnv -> LogEnv) -> ResourceT m a -> ResourceT m a
localLogEnv = (m a -> m a) -> ResourceT m a -> ResourceT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> ResourceT m a -> ResourceT n b
transResourceT ((m a -> m a) -> ResourceT m a -> ResourceT m a)
-> ((LogEnv -> LogEnv) -> m a -> m a)
-> (LogEnv -> LogEnv)
-> ResourceT m a
-> ResourceT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> LogEnv) -> m a -> m a
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 { KatipT m a -> ReaderT LogEnv m a
unKatipT :: ReaderT LogEnv m a }
  deriving ( a -> KatipT m b -> KatipT m a
(a -> b) -> KatipT m a -> KatipT m b
(forall a b. (a -> b) -> KatipT m a -> KatipT m b)
-> (forall a b. a -> KatipT m b -> KatipT m a)
-> Functor (KatipT m)
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
<$ :: a -> KatipT m b -> KatipT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> KatipT m b -> KatipT m a
fmap :: (a -> b) -> KatipT m a -> KatipT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> KatipT m a -> KatipT m b
Functor, Functor (KatipT m)
a -> KatipT m a
Functor (KatipT m)
-> (forall a. a -> KatipT m a)
-> (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 a b. KatipT m a -> KatipT m b -> KatipT m b)
-> (forall a b. KatipT m a -> KatipT m b -> KatipT m a)
-> Applicative (KatipT m)
KatipT m a -> KatipT m b -> KatipT m b
KatipT m a -> KatipT m b -> KatipT m a
KatipT m (a -> b) -> KatipT m a -> KatipT m b
(a -> b -> c) -> KatipT m a -> KatipT m b -> KatipT m c
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
<* :: 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
*> :: 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 :: (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
<*> :: 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 :: a -> KatipT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> KatipT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (KatipT m)
Applicative, Applicative (KatipT m)
a -> KatipT m a
Applicative (KatipT m)
-> (forall a b. KatipT m a -> (a -> KatipT m b) -> KatipT m b)
-> (forall a b. KatipT m a -> KatipT m b -> KatipT m b)
-> (forall a. a -> KatipT m a)
-> Monad (KatipT m)
KatipT m a -> (a -> KatipT m b) -> KatipT m b
KatipT m a -> KatipT m b -> KatipT m b
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 :: a -> KatipT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> KatipT m a
>> :: 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
>>= :: 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
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (KatipT m)
Monad, Monad (KatipT m)
Monad (KatipT m)
-> (forall a. IO a -> KatipT m a) -> MonadIO (KatipT m)
IO a -> KatipT m a
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 :: IO a -> KatipT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> KatipT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (KatipT m)
MonadIO
           , MonadCatch (KatipT m)
MonadCatch (KatipT m)
-> (forall b.
    ((forall a. KatipT m a -> KatipT m a) -> KatipT m b) -> KatipT m b)
-> (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))
-> MonadMask (KatipT m)
KatipT m a
-> (a -> ExitCase b -> KatipT m c)
-> (a -> KatipT m b)
-> KatipT m (b, c)
((forall a. KatipT m a -> KatipT m a) -> KatipT m b) -> KatipT m b
((forall a. KatipT m a -> KatipT m a) -> KatipT m b) -> KatipT m b
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 :: * -> *).
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
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)
generalBracket :: 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 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 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
$cp1MonadMask :: forall (m :: * -> *). MonadMask m => MonadCatch (KatipT m)
MonadMask, MonadThrow (KatipT m)
MonadThrow (KatipT m)
-> (forall e a.
    Exception e =>
    KatipT m a -> (e -> KatipT m a) -> KatipT m a)
-> MonadCatch (KatipT m)
KatipT m a -> (e -> KatipT m a) -> KatipT m a
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 :: 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
$cp1MonadCatch :: forall (m :: * -> *). MonadCatch m => MonadThrow (KatipT m)
MonadCatch, Monad (KatipT m)
e -> KatipT m a
Monad (KatipT m)
-> (forall e a. Exception e => e -> KatipT m a)
-> MonadThrow (KatipT m)
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 :: e -> KatipT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> KatipT m a
$cp1MonadThrow :: forall (m :: * -> *). MonadThrow m => Monad (KatipT m)
MonadThrow, MonadIO (KatipT m)
MonadIO (KatipT m)
-> (forall a. ResourceT IO a -> KatipT m a)
-> MonadResource (KatipT m)
ResourceT IO a -> KatipT m a
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 :: ResourceT IO a -> KatipT m a
$cliftResourceT :: forall (m :: * -> *) a.
MonadResource m =>
ResourceT IO a -> KatipT m a
$cp1MonadResource :: forall (m :: * -> *). MonadResource m => MonadIO (KatipT m)
MonadResource, m a -> KatipT m a
(forall (m :: * -> *) a. Monad m => m a -> KatipT m a)
-> MonadTrans KatipT
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 :: 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 = ReaderT LogEnv m LogEnv -> KatipT m LogEnv
forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT ReaderT LogEnv m LogEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    localLogEnv :: (LogEnv -> LogEnv) -> KatipT m a -> KatipT m a
localLogEnv LogEnv -> LogEnv
f (KatipT ReaderT LogEnv m a
m) = ReaderT LogEnv m a -> KatipT m a
forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT (ReaderT LogEnv m a -> KatipT m a)
-> ReaderT LogEnv m a -> KatipT m a
forall a b. (a -> b) -> a -> b
$ (LogEnv -> LogEnv) -> ReaderT LogEnv m a -> ReaderT LogEnv m a
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 :: (Run KatipT -> m a) -> KatipT m a
liftWith Run KatipT -> m a
f = ReaderT LogEnv m a -> KatipT m a
forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT (ReaderT LogEnv m a -> KatipT m a)
-> ReaderT LogEnv m a -> KatipT m a
forall a b. (a -> b) -> a -> b
$ (LogEnv -> m a) -> ReaderT LogEnv m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((LogEnv -> m a) -> ReaderT LogEnv m a)
-> (LogEnv -> m a) -> ReaderT LogEnv m a
forall a b. (a -> b) -> a -> b
$ \LogEnv
le -> Run KatipT -> m a
f (Run KatipT -> m a) -> Run KatipT -> m a
forall a b. (a -> b) -> a -> b
$ \KatipT n b
t -> LogEnv -> KatipT n b -> n b
forall (m :: * -> *) a. LogEnv -> KatipT m a -> m a
runKatipT LogEnv
le KatipT n b
t
    restoreT :: m (StT KatipT a) -> KatipT m a
restoreT = ReaderT LogEnv m a -> KatipT m a
forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT (ReaderT LogEnv m a -> KatipT m a)
-> (m a -> ReaderT LogEnv m a) -> m a -> KatipT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogEnv -> m a) -> ReaderT LogEnv m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((LogEnv -> m a) -> ReaderT LogEnv m a)
-> (m a -> LogEnv -> m a) -> m a -> ReaderT LogEnv m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> LogEnv -> m a
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 :: (RunInBase (KatipT m) b -> b a) -> KatipT m a
liftBaseWith = (RunInBase (KatipT m) b -> b a) -> KatipT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: StM (KatipT m) a -> KatipT m a
restoreM = StM (KatipT m) a -> KatipT m a
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 a. KatipT m a -> IO a) -> IO b) -> KatipT m b
withRunInIO (forall a. KatipT m a -> IO a) -> IO b
inner = ReaderT LogEnv m b -> KatipT m b
forall (m :: * -> *) a. ReaderT LogEnv m a -> KatipT m a
KatipT (ReaderT LogEnv m b -> KatipT m b)
-> ReaderT LogEnv m b -> KatipT m b
forall a b. (a -> b) -> a -> b
$ (LogEnv -> m b) -> ReaderT LogEnv m b
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((LogEnv -> m b) -> ReaderT LogEnv m b)
-> (LogEnv -> m b) -> ReaderT LogEnv m b
forall a b. (a -> b) -> a -> b
$ \LogEnv
le -> ((forall a. m a -> IO a) -> IO b) -> m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO b) -> m b)
-> ((forall a. m a -> IO a) -> IO b) -> m b
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
    (forall a. KatipT m a -> IO a) -> IO b
inner (m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> (KatipT m a -> m a) -> KatipT m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogEnv -> KatipT m a -> m a
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 :: String -> KatipT m a
fail String
msg = m a -> KatipT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (String -> m a
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 :: LogEnv -> KatipT m a -> m a
runKatipT LogEnv
le (KatipT ReaderT LogEnv m a
f) = ReaderT LogEnv m a -> LogEnv -> m a
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 :: m a -> m a
katipNoLogging = (LogEnv -> LogEnv) -> m a -> m a
forall (m :: * -> *) a. Katip m => (LogEnv -> LogEnv) -> m a -> m a
localLogEnv (\LogEnv
le -> ((Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
 -> LogEnv -> Identity LogEnv)
-> Map Text ScribeHandle -> LogEnv -> LogEnv
forall s t a b. ASetter s t a b -> b -> s -> t
set (Map Text ScribeHandle -> Identity (Map Text ScribeHandle))
-> LogEnv -> Identity LogEnv
Lens' LogEnv (Map Text ScribeHandle)
logEnvScribes Map Text ScribeHandle
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 :: 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
..} <- m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    Item a -> m ()
forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
Item a -> m ()
logKatipItem (Item a -> m ()) -> m (Item a) -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Item a) -> m (Item a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
      (Namespace
-> Environment
-> Severity
-> ThreadIdText
-> String
-> ProcessID
-> a
-> LogStr
-> UTCTime
-> Namespace
-> Maybe Loc
-> Item a
forall a.
Namespace
-> Environment
-> Severity
-> ThreadIdText
-> String
-> ProcessID
-> a
-> LogStr
-> UTCTime
-> Namespace
-> Maybe Loc
-> Item a
Item (Namespace
 -> Environment
 -> Severity
 -> ThreadIdText
 -> String
 -> ProcessID
 -> a
 -> LogStr
 -> UTCTime
 -> Namespace
 -> Maybe Loc
 -> Item a)
-> IO Namespace
-> IO
     (Environment
      -> Severity
      -> ThreadIdText
      -> String
      -> ProcessID
      -> a
      -> LogStr
      -> UTCTime
      -> Namespace
      -> Maybe Loc
      -> Item a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Namespace -> IO Namespace
forall (f :: * -> *) a. Applicative f => a -> f a
pure Namespace
_logEnvApp
            IO
  (Environment
   -> Severity
   -> ThreadIdText
   -> String
   -> ProcessID
   -> a
   -> LogStr
   -> UTCTime
   -> Namespace
   -> Maybe Loc
   -> Item a)
-> IO Environment
-> IO
     (Severity
      -> ThreadIdText
      -> String
      -> ProcessID
      -> a
      -> LogStr
      -> UTCTime
      -> Namespace
      -> Maybe Loc
      -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Environment -> IO Environment
forall (f :: * -> *) a. Applicative f => a -> f a
pure Environment
_logEnvEnv
            IO
  (Severity
   -> ThreadIdText
   -> String
   -> ProcessID
   -> a
   -> LogStr
   -> UTCTime
   -> Namespace
   -> Maybe Loc
   -> Item a)
-> IO Severity
-> IO
     (ThreadIdText
      -> String
      -> ProcessID
      -> a
      -> LogStr
      -> UTCTime
      -> Namespace
      -> Maybe Loc
      -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Severity -> IO Severity
forall (f :: * -> *) a. Applicative f => a -> f a
pure Severity
sev
            IO
  (ThreadIdText
   -> String
   -> ProcessID
   -> a
   -> LogStr
   -> UTCTime
   -> Namespace
   -> Maybe Loc
   -> Item a)
-> IO ThreadIdText
-> IO
     (String
      -> ProcessID
      -> a
      -> LogStr
      -> UTCTime
      -> Namespace
      -> Maybe Loc
      -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ThreadId -> ThreadIdText
mkThreadIdText (ThreadId -> ThreadIdText) -> IO ThreadId -> IO ThreadIdText
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ThreadId
myThreadId)
            IO
  (String
   -> ProcessID
   -> a
   -> LogStr
   -> UTCTime
   -> Namespace
   -> Maybe Loc
   -> Item a)
-> IO String
-> IO
     (ProcessID
      -> a -> LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> IO String
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
_logEnvHost
            IO
  (ProcessID
   -> a -> LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
-> IO ProcessID
-> IO (a -> LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProcessID -> IO ProcessID
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessID
_logEnvPid
            IO (a -> LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
-> IO a
-> IO (LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
            IO (LogStr -> UTCTime -> Namespace -> Maybe Loc -> Item a)
-> IO LogStr -> IO (UTCTime -> Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LogStr -> IO LogStr
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogStr
msg
            IO (UTCTime -> Namespace -> Maybe Loc -> Item a)
-> IO UTCTime -> IO (Namespace -> Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO UTCTime
_logEnvTimer
            IO (Namespace -> Maybe Loc -> Item a)
-> IO Namespace -> IO (Maybe Loc -> Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Namespace -> IO Namespace
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Namespace
_logEnvApp Namespace -> Namespace -> Namespace
forall a. Semigroup a => a -> a -> a
<> Namespace
ns)
            IO (Maybe Loc -> Item a) -> IO (Maybe Loc) -> IO (Item a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Loc -> IO (Maybe Loc)
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 :: 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
..} <- m LogEnv
forall (m :: * -> *). Katip m => m LogEnv
getLogEnv
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
      [ScribeHandle] -> (ScribeHandle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
FT.forM_ (Map Text ScribeHandle -> [ScribeHandle]
forall k a. Map k a -> [a]
M.elems Map Text ScribeHandle
_logEnvScribes) ((ScribeHandle -> IO ()) -> IO ())
-> (ScribeHandle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ ScribeHandle {TBQueue WorkerMessage
Scribe
shChan :: TBQueue WorkerMessage
shScribe :: Scribe
shChan :: ScribeHandle -> TBQueue WorkerMessage
shScribe :: ScribeHandle -> Scribe
..} -> do
        IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Scribe -> Item a -> IO Bool
Scribe -> PermitFunc
scribePermitItem Scribe
shScribe Item a
item) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ STM Bool -> IO Bool
forall a. STM a -> IO a
atomically (TBQueue WorkerMessage -> WorkerMessage -> STM Bool
forall a. TBQueue a -> a -> STM Bool
tryWriteTBQueue TBQueue WorkerMessage
shChan (Item a -> WorkerMessage
forall a. LogItem a => Item a -> WorkerMessage
NewItem Item a
item))

-------------------------------------------------------------------------------
tryWriteTBQueue
    :: TBQueue a
    -> a
    -> STM Bool
    -- ^ Did we write?
tryWriteTBQueue :: TBQueue a -> a -> STM Bool
tryWriteTBQueue TBQueue a
q a
a = do
  Bool
full <- TBQueue a -> STM Bool
forall a. TBQueue a -> STM Bool
isFullTBQueue TBQueue a
q
  Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
full (TBQueue a -> a -> STM ()
forall a. TBQueue a -> a -> STM ()
writeTBQueue TBQueue a
q a
a)
  Bool -> STM Bool
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 :: a -> Namespace -> Severity -> LogStr -> m ()
logF a
a Namespace
ns Severity
sev LogStr
msg = a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
logItem a
a Namespace
ns Maybe Loc
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 :: a -> Namespace -> Severity -> m b -> m b
logException a
a Namespace
ns Severity
sev m b
action = m b
action m b -> (SomeException -> m b) -> m b
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
e -> SomeException -> m ()
f SomeException
e m () -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
  where
    f :: SomeException -> m ()
f SomeException
e = a -> Namespace -> Severity -> LogStr -> m ()
forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Severity -> LogStr -> m ()
logF a
a Namespace
ns Severity
sev (SomeException -> LogStr
forall a. Show a => a -> LogStr
msg SomeException
e)
    msg :: a -> LogStr
msg a
e = Text -> LogStr
forall a. StringConv a Text => a -> LogStr
ls (String -> Text
T.pack String
"An exception has occurred: ") LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> a -> LogStr
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 :: Namespace -> Severity -> LogStr -> m ()
logMsg Namespace
ns Severity
sev LogStr
msg = () -> Namespace -> Severity -> LogStr -> m ()
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 :: Maybe Loc
getLoc = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
HasCallStack => CallStack
callStack of
  [] -> Maybe Loc
forall a. Maybe a
Nothing
  [(String, SrcLoc)]
xs -> Loc -> Maybe Loc
forall a. a -> Maybe a
Just (Loc -> Maybe Loc)
-> ([(String, SrcLoc)] -> Loc) -> [(String, SrcLoc)] -> Maybe Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> Loc
toLoc ((String, SrcLoc) -> Loc)
-> ([(String, SrcLoc)] -> (String, SrcLoc))
-> [(String, SrcLoc)]
-> Loc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(String, SrcLoc)] -> (String, SrcLoc)
forall a. [a] -> a
head ([(String, SrcLoc)] -> Maybe Loc)
-> [(String, SrcLoc)] -> Maybe Loc
forall a b. (a -> b) -> a -> b
$ ((String, SrcLoc) -> Bool)
-> [(String, SrcLoc)] -> [(String, SrcLoc)]
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
      String
"katip-" String -> String -> Bool
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 :: String -> String -> String -> CharPos -> CharPos -> Loc
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 :: a -> Namespace -> Severity -> LogStr -> m ()
logLoc a
a Namespace
ns = a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
logItem a
a Namespace
ns Maybe Loc
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) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: (Loc -> String
loc_module Loc
loc) String -> ShowS
forall a. [a] -> [a] -> [a]
++
  Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: (Loc -> String
loc_filename Loc
loc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: (Loc -> String
line Loc
loc) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
':' Char -> ShowS
forall a. a -> [a] -> [a]
: (Loc -> String
char Loc
loc)
  where
    line :: Loc -> String
line = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPos -> Int
forall a b. (a, b) -> a
fst (CharPos -> Int) -> (Loc -> CharPos) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_start
    char :: Loc -> String
char = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> (Loc -> Int) -> Loc -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CharPos -> Int
forall a b. (a, b) -> b
snd (CharPos -> Int) -> (Loc -> CharPos) -> Loc -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> CharPos
loc_start