katip 0.5.5.1 → 0.8.8.4

raw patch · 17 files changed

Files

• README.md +4/−1
• Setup.hs +1/−0
• bench/Main.hs +45/−42
• changelog.md +107/−0
• examples/example.hs +37/−47
• examples/example_lens.hs +36/−45
• katip.cabal +31/−30
• src/Katip.hs +191/−167
• src/Katip/Core.hs +290/−121
• src/Katip/Format/Time.hs +100/−92
• src/Katip/Monadic.hs +260/−218
• src/Katip/Scribes/Handle.hs +164/−75
• test/Katip/Tests.hs +249/−192
• test/Katip/Tests/Format/Time.hs +45/−48
• test/Katip/Tests/Scribes/Handle-text.golden +38/−38
• test/Katip/Tests/Scribes/Handle.hs +199/−159
• test/Main.hs +10/−8

@@ -16,7 +16,7 @@   add context that will be automatically merged in with existing log   context. -* *Easy to Integration:* Katip was designed to be easily integrated+* *Easy Integration:* Katip was designed to be easily integrated   into existing monads. By using typeclasses for logging facilities,   individual subsystems and even libraries can easily add their own   namespacing and context without having any knowledge of their@@ -84,3 +84,6 @@ * [Leonid Onokhov](https://github.com/sopvop) * [Alexander Vershilov](https://github.com/qnikst) * [Chris Martin](https://github.com/chris-martin)+* [Domen Kožar](https://github.com/domenkozar)+* [Tristan Bull](https://github.com/tmbull)+* [Aleksey Khudyakov](https://github.com/Shimuuar)

@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain

@@ -1,58 +1,61 @@-{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE StandaloneDeriving         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Main-    ( main-    ) where +module Main+  ( main,+  )+where  --------------------------------------------------------------------------------import           Control.Concurrent-import           Control.DeepSeq-import           Control.Exception.Safe-import           Control.Monad-import           Criterion.Main-import           Data.Aeson-import           Data.Monoid            as M-import           System.Directory-import           System.FilePath-import           System.IO-import           System.Posix+import Control.Concurrent+import Control.DeepSeq+import Control.Exception.Safe+import Control.Monad+import Criterion.Main+import Data.Aeson+import Data.Monoid as M --------------------------------------------------------------------------------import           Katip.Core-import           Katip.Scribes.Handle+import Katip.Core+import Katip.Scribes.Handle+import System.Directory+import System.FilePath+import System.IO+import System.Posix+ -------------------------------------------------------------------------------  main :: IO ()-main = defaultMain [-    handleScribeBench-  ]-+main =+  defaultMain+    [ handleScribeBench+    ]  ------------------------------------------------------------------------------- handleScribeBench :: Benchmark handleScribeBench = bgroup "Katip.Scribes.Handle" $-  flip map destinations $ \dest -> bgroup (show dest) [-   -- This is variably wildly on disk performance but should be a-   -- better test since a push test basically just tests how fast your-   -- queue structure is.-     bench "full env, flush 1000 writes" $-       whnfIO $ do-         le <- setupHandleLogEnv dest-         runKatipT le $ replicateM_ 1000 $ logItem ExPayload "namespace" Nothing InfoS "example"-         closeScribes le-   ]+  flip map destinations $ \dest ->+    bgroup+      (show dest)+      [ -- This is variably wildly on disk performance but should be a+        -- better test since a push test basically just tests how fast your+        -- queue structure is.+        bench "full env, flush 1000 writes" $+          whnfIO $ do+            le <- setupHandleLogEnv dest+            runKatipT le $ replicateM_ 1000 $ logItem ExPayload "namespace" Nothing InfoS "example"+            closeScribes le+      ]   where     destinations = [DevNull, TempFile]-    --destinations = [DevNull] +--destinations = [DevNull]  ------------------------------------------------------------------------------- data HandleDest = DevNull | TempFile deriving (Show, Eq) - ------------------------------------------------------------------------------- instance NFData LogEnv where   rnf (LogEnv !_ !_ !_ !_ !_ !_) = ()@@ -62,7 +65,6 @@   (scr, _) <- setupHandleEnv hd   registerScribe "handle" scr defaultScribeSettings =<< initLogEnv "katip-bench" "bench" - ------------------------------------------------------------------------------- setupHandleEnv :: HandleDest -> IO (Scribe, ThreadIdText) setupHandleEnv dest = do@@ -70,7 +72,6 @@   tid <- myThreadId   return (scribe, mkThreadIdText tid) - ------------------------------------------------------------------------------- data ExPayload = ExPayload @@ -82,7 +83,6 @@ instance LogItem ExPayload where   payloadKeys _ _ = AllKeys - ------------------------------------------------------------------------------- setup :: HandleDest -> IO Scribe setup dest = do@@ -92,13 +92,16 @@       return (tmp </> "katip-bench.log")     DevNull -> return ("/dev/null")   h <- openFile outFile WriteMode-  s <- mkHandleScribe ColorIfTerminal h DebugS V0+  s <- mkHandleScribe ColorIfTerminal h (permitItem DebugS) V0   let cleanupHandle = hClose h `finally` (when (dest == TempFile) (removeLink outFile))-  return s { scribeFinalizer = scribeFinalizer s `finally` cleanupHandle}-+  return s {scribeFinalizer = scribeFinalizer s `finally` cleanupHandle}  ------------------------------------------------------------------------------- deriving instance NFData ThreadIdText  instance NFData Scribe where-  rnf (Scribe a b) = (a :: Item ExPayload -> IO ()) `seq` b `seq` ()+  rnf (Scribe a b p) =+    (a :: Item ExPayload -> IO ())+      `seq` b+      `seq` (p :: Item ExPayload -> IO Bool)+      `seq` ()

@@ -1,3 +1,110 @@+0.8.8.4+=======+* Fix build on GHC 9.6 and below [#160](https://github.com/Soostone/katip/pull/160)++0.8.8.3+=======+* Don't rely on package names in `getLoc` [#159](https://github.com/Soostone/katip/pull/159)++0.8.8.2+=======+* Performance improvements [#152](https://github.com/Soostone/katip/pull/152)++0.8.8.1+=======+* Improve logging performance (4x) via inlining [#151](https://github.com/Soostone/katip/pull/151)++0.8.8.0+=======+* Add support for rendering arrays in the log context to the handle scribe [#150](https://github.com/Soostone/katip/pull/150)++0.8.7.4+=======+* Allow up to GHC 9.6 for Windows [#145](https://github.com/Soostone/katip/pull/145)++0.8.7.3+=======+* unix 2.8 compatibility [#143](https://github.com/Soostone/katip/pull/143)++0.8.7.2+=======+* MTL 2.3 compatibility [#140](https://github.com/Soostone/katip/pull/140)++0.8.7.1+=======+* Text 2 compatibility [#138](https://github.com/Soostone/katip/pull/138)++0.8.7.0+=======+* Aeson 2 compatibility [#131](https://github.com/Soostone/katip/pull/131)++0.8.6.0+=======+* GHC 8.10 compatibility++0.8.5.0+=======+* Add MonadResource instances [#121](https://github.com/Soostone/katip/pull/121)++0.8.4.0+=======+* Add support for unliftio-core 0.2 while maintaining backwards-compatible support for 0.1++0.8.3.0+=======++* Add `logKatipItem` function and reimplement `logItem` to use it. [vlatkoB](https://github.com/vlatkoB)++0.8.2.0+=======+* Add `MonadFail` instances for `base` >= 4.9.0.0 [Koray Al](https://github.com/korayal)++0.8.1.0+=======+* Export `logLoc`. Credit to [Brian McKenna](https://github.com/puffnfresh)++0.8.0.0+=======+* **Breaking change**: switch from severity based log level filtering to+  user-definable `PermitFunc`. To upgrade, any time you initialize one+  of the standard scribes, rather than providing a severity like+  `InfoS`, instead pass in `(permitItem InfoS)`. Credit to+  [vlatkoB](https://github.com/vlatkoB).+* Update some misformatted and outdated docs.+* Set lower bound of base to 4.9.0.0, the version shipped with GHC+  8.0.2. Support for GHC versions older than that is removed.+* Update default formatter of Handle scribe to format pid as `[PID+  1234]` instead of `[1234]` and `[ThreadId 1234]` instead of+  `[1234]`.+* Add missing `Bounded` instance for `Verbosity`. This allows you to+  easily enumerate all verbosities via `[minBound..maxBound]`.++0.7.0.0+=======+* Exclusively use HasCallstack for location reporting in errors. Credit to [Domen Kožar](https://github.com/domenkozar)+* Drop support for GHC 7.x++0.6.3.0+=======+* Add `ToJSON`/`FromJSON` instances for Verbosity. Credit to [Aleksey Khudyakov](https://github.com/Shimuuar).++0.6.2.1+=======+* Add `mkHandleScribeWithFormatter`. This allows control over the format of log items going to a handle. Credit to [Tristan Bull](https://github.com/tmbull) for the implementation.+* Documentation fixes. Credit to [Domen Kožar](https://github.com/domenkozar) for the implementation.+* Add `jsonFormat` handle formatter.+* Deprecate `formatItem` which is now replaced by `bracketFormat`.++0.6.1.0+=======+* Loosen deps+* Support latest STM++0.6.0.0+=======+* Drop ListT instance due to deprecations.+* Loosen dependencies.+ 0.5.5.1 ======= * Decrease default timer resolution from 1s to 1ms.

@@ -1,29 +1,30 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}-module Main-    ( main-    ) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} +module Main+  ( main,+  )+where  --------------------------------------------------------------------------------import qualified Control.Applicative         as A-import           Control.Exception-import           Control.Monad.Base-import           Control.Monad.Reader-import           Control.Monad.Trans.Control-import           Data.Aeson-import           Data.Monoid                 as M-import           System.IO                   (stdout)---------------------------------------------------------------------------------import           Katip+import qualified Control.Applicative as A+import Control.Exception+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Aeson+import Data.Monoid as M -------------------------------------------------------------------------------+import Katip+import System.IO (stdout) +-------------------------------------------------------------------------------  -- | An example of advanced katip usage. Be sure to check out -- example_lens.hs for a slightly cleaner and more general pattern.@@ -36,7 +37,7 @@   -- hot-swap scribes at runtime if you need to. 'closeScribes' is   -- blocking and flushes all messages out of a scribe and cleans up   -- resources that were allocated at creation.-  handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2+  handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2   let mkLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"   bracket mkLogEnv closeScribes $ \le -> do     let s = MyState M.mempty mempty le@@ -49,47 +50,41 @@       -- use this to stack up various contextual details throughout your       -- code and they will be flattened out and combined in the log       -- output.-      katipAddNamespace "confrabulation" $ katipAddContext (ConfrabLogCTX 42) $ do-        $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"-        confrabulateWidgets+      katipAddNamespace "confrabulation" $+        katipAddContext (ConfrabLogCTX 42) $ do+          $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"+          confrabulateWidgets       $(logTM) InfoS "Namespace and context are back to normal"       katipNoLogging $         $(logTM) DebugS "You'll never see this log message!" - ------------------------------------------------------------------------------- newtype ConfrabLogCTX = ConfrabLogCTX Int - instance ToJSON ConfrabLogCTX where   toJSON (ConfrabLogCTX factor) = object ["confrab_factor" .= factor] - instance ToObject ConfrabLogCTX - instance LogItem ConfrabLogCTX where   payloadKeys _verb _a = AllKeys - ------------------------------------------------------------------------------- confrabulateWidgets :: (Monad m) => m () confrabulateWidgets = return () - --------------------------------------------------------------------------------data MyState = MyState {-    msKNamespace :: Namespace-  , msKContext   :: LogContexts-  , msLogEnv     :: LogEnv+data MyState = MyState+  { msKNamespace :: Namespace,+    msKContext :: LogContexts,+    msLogEnv :: LogEnv   } - --------------------------------------------------------------------------------newtype MyStack m a = MyStack {-      unStack :: ReaderT MyState m a-    } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans)-+newtype MyStack m a = MyStack+  { unStack :: ReaderT MyState m a+  }+  deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans)  -- MonadBase, MonadTransControl, and MonadBaseControl aren't strictly -- needed for this example, but they are commonly required and@@ -98,30 +93,25 @@ instance MonadBase b m => MonadBase b (MyStack m) where   liftBase = liftBaseDefault - instance MonadTransControl MyStack where   type StT MyStack a = StT (ReaderT Int) a   liftWith = defaultLiftWith MyStack unStack   restoreT = defaultRestoreT MyStack - instance MonadBaseControl b m => MonadBaseControl b (MyStack m) where   type StM (MyStack m) a = ComposeSt MyStack m a   liftBaseWith = defaultLiftBaseWith   restoreM = defaultRestoreM - instance (MonadIO m) => Katip (MyStack m) where   getLogEnv = asks msLogEnv-  localLogEnv f (MyStack m) = MyStack (local (\s -> s { msLogEnv = f (msLogEnv s)}) m)-+  localLogEnv f (MyStack m) = MyStack (local (\s -> s {msLogEnv = f (msLogEnv s)}) m)  instance (MonadIO m) => KatipContext (MyStack m) where   getKatipContext = asks msKContext-  localKatipContext f (MyStack m) = MyStack (local (\s -> s { msKContext = f (msKContext s)}) m)+  localKatipContext f (MyStack m) = MyStack (local (\s -> s {msKContext = f (msKContext s)}) m)   getKatipNamespace = asks msKNamespace-  localKatipNamespace f (MyStack m) = MyStack (local (\s -> s { msKNamespace = f (msKNamespace s)}) m)-+  localKatipNamespace f (MyStack m) = MyStack (local (\s -> s {msKNamespace = f (msKNamespace s)}) m)  ------------------------------------------------------------------------------- runStack :: MyState -> MyStack m a -> m a

@@ -1,46 +1,46 @@-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}-module Main-    ( main-    ) where+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} +module Main+  ( main,+  )+where  --------------------------------------------------------------------------------import           Control.Applicative         as A-import           Control.Exception-import           Control.Lens                hiding ((.=))-import           Control.Monad.Base-import           Control.Monad.Reader-import           Control.Monad.Trans.Control-import           Data.Aeson-import           Data.Monoid                 as M-import           System.IO                   (stdout)---------------------------------------------------------------------------------import           Katip+import Control.Applicative as A+import Control.Exception+import Control.Lens hiding ((.=))+import Control.Monad.Base+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Aeson+import Data.Monoid as M -------------------------------------------------------------------------------+import Katip+import System.IO (stdout) +------------------------------------------------------------------------------- -data MyState = MyState {-    _msKNamespace :: Namespace-  , _msKContext   :: LogContexts-  , _msLogEnv     :: LogEnv+data MyState = MyState+  { _msKNamespace :: Namespace,+    _msKContext :: LogContexts,+    _msLogEnv :: LogEnv   } - -- This gives us HasMyState, which is helpful for complex stacks where -- MyState may be nested somewhere deeper inside a larger data -- structure. You can keep functions that operate on MyState as -- general as possible. makeClassy ''MyState - -------------------------------------------------------------------------------+ -- | An example of advanced katip usage with Lens. main :: IO () main = do@@ -51,7 +51,7 @@   -- hot-swap scribes at runtime if you need to. 'closeScribes' is   -- blocking and flushes all messages out of a scribe and cleans up   -- resources that were allocated at creation.-  handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2+  handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2   let mkLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"   bracket mkLogEnv closeScribes $ \le -> do     let s = MyState M.mempty mempty le@@ -64,39 +64,34 @@       -- use this to stack up various contextual details throughout your       -- code and they will be flattened out and combined in the log       -- output.-      katipAddNamespace "confrabulation" $ katipAddContext (ConfrabLogCTX 42) $ do-        $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"-        confrabulateWidgets+      katipAddNamespace "confrabulation" $+        katipAddContext (ConfrabLogCTX 42) $ do+          $(logTM) DebugS "Confrabulating widgets, with extra namespace and context"+          confrabulateWidgets       $(logTM) InfoS "Namespace and context are back to normal"       katipNoLogging $         $(logTM) DebugS "You'll never see this log message!" - ------------------------------------------------------------------------------- newtype ConfrabLogCTX = ConfrabLogCTX Int - instance ToJSON ConfrabLogCTX where   toJSON (ConfrabLogCTX factor) = object ["confrab_factor" .= factor] - instance ToObject ConfrabLogCTX - instance LogItem ConfrabLogCTX where   payloadKeys _verb _a = AllKeys - ------------------------------------------------------------------------------- confrabulateWidgets :: (Monad m) => m () confrabulateWidgets = return () - --------------------------------------------------------------------------------newtype MyStack m a = MyStack {-      unStack :: ReaderT MyState m a-    } deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans)-+newtype MyStack m a = MyStack+  { unStack :: ReaderT MyState m a+  }+  deriving (MonadReader MyState, Functor, A.Applicative, Monad, MonadIO, MonadTrans)  -- MonadBase, MonadTransControl, and MonadBaseControl aren't strictly -- needed for this example, but they are commonly required and@@ -105,13 +100,11 @@ instance MonadBase b m => MonadBase b (MyStack m) where   liftBase = liftBaseDefault - instance MonadTransControl MyStack where   type StT MyStack a = StT (ReaderT Int) a   liftWith = defaultLiftWith MyStack unStack   restoreT = defaultRestoreT MyStack - instance MonadBaseControl b m => MonadBaseControl b (MyStack m) where   type StM (MyStack m) a = ComposeSt MyStack m a   liftBaseWith = defaultLiftBaseWith@@ -121,13 +114,11 @@   getLogEnv = view msLogEnv   localLogEnv f (MyStack m) = MyStack (local (over msLogEnv f) m) - instance (MonadIO m) => KatipContext (MyStack m) where   getKatipContext = view msKContext   localKatipContext f (MyStack m) = MyStack (local (over msKContext f) m)   getKatipNamespace = view msKNamespace   localKatipNamespace f (MyStack m) = MyStack (local (over msKNamespace f) m)-  ------------------------------------------------------------------------------- runStack :: MyState -> MyStack m a -> m a

@@ -1,5 +1,5 @@ name:                katip-version:             0.5.5.1+version:             0.8.8.4 synopsis:            A structured logging framework. description:   Katip is a structured logging framework. See README.md for more details.@@ -25,7 +25,7 @@   test/Katip/Tests/Scribes/Handle.hs   test/Katip/Tests/Scribes/Handle-text.golden   test/Katip/Tests/Format/Time.hs-tested-with: GHC == 7.8.4, GHC== 7.10.3+tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2  source-repository head   type:     git@@ -53,44 +53,45 @@     TemplateHaskell     OverloadedStrings -  build-depends: base >=4.5 && <5-               , aeson >=0.6 && <1.4-               , async < 3.0.0.0-               , auto-update >= 0.1 && < 0.2-               , bytestring >= 0.9 && < 0.11-               , containers >=0.4 && <0.6-               , either >= 4 && < 5.1+  build-depends: base >=4.9.0.0 && <5+               , aeson >=1.0.0.0+               , async >= 2.0.0.0 && < 3.0.0.0+               , auto-update >= 0.1+               , bytestring >= 0.9+               , containers >=0.4+               , either >= 4                , safe-exceptions >= 0.1.0.0-               , hostname >=1.0 && <1.1-               , old-locale >= 1.0 && < 1.1-               , string-conv >= 0.1 && < 0.2-               , template-haskell >= 2.8 && < 2.14-               , text >= 0.11 && <1.3-               , time >= 1 && < 1.9-               , transformers >= 0.3 && < 0.6+               , hostname >=1.0+               , old-locale >= 1.0+               , string-conv >= 0.1+               , template-haskell >= 2.8+               , text >= 1.2.4.0+               , time >= 1+               , transformers >= 0.3                , transformers-compat-               , unordered-containers >= 0.2 && < 0.3-               , monad-control >= 1.0 && < 1.1-               , mtl >= 2.0 && < 2.3-               , transformers-base >= 0.3 && < 0.6-               , resourcet >= 1.1 && < 1.3+               , unordered-containers >= 0.2+               , monad-control >= 1.0+               , mtl >= 2.0+               , transformers-base >= 0.3+               , resourcet >= 1.2.0                , scientific >= 0.3.3.0-               , microlens >= 0.2.0.0 && < 0.5-               , microlens-th >= 0.1.0.0 && < 0.5+               , microlens >= 0.2.0.0+               , microlens-th >= 0.1.0.0                , semigroups-               , unliftio-core >= 0.1 && < 0.2-               , stm >= 2.4+               , unliftio-core >= 0.1+               , stm >= 2.4.4.1+               , vector    hs-source-dirs:      src   default-language:    Haskell2010-  ghc-options:        -Wall+  ghc-options:        -Wall -O2   if flag(lib-Werror)     ghc-options: -Werror   if os(windows)-    build-depends: Win32 >=2.3 && <2.6+    build-depends: Win32 >=2.3 && <2.14     exposed-modules: Katip.Compat   else-    build-depends: unix >= 2.5 && <2.8+    build-depends: unix >= 2.5 && <2.9   test-suite test@@ -114,7 +115,7 @@                , template-haskell                , text                , time-               , time-locale-compat >= 0.1.0.1 && < 0.2+               , time-locale-compat >= 0.1.0.1                , directory                , regex-tdfa                , unordered-containers@@ -132,7 +133,7 @@   main-is: Main.hs   hs-source-dirs: bench   default-language:    Haskell2010-  ghc-options: -O2 -Wall -threaded -rtsopts -with-rtsopts=-N+  ghc-options: -O2 -Wall -threaded -rtsopts "-with-rtsopts=-N"   if flag(lib-Werror)     ghc-options: -Werror   build-depends:

@@ -6,15 +6,17 @@ -- -- @ --+-- {-# LANGUAGE OverloadedStrings #-}+-- {-# LANGUAGE TemplateHaskell #-} -- import Control.Exception -- import Katip -- -- main :: IO () -- main = do---   handleScribe <- mkHandleScribe ColorIfTerminal stdout InfoS V2---   let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv "MyApp" "production"+--   handleScribe <- mkHandleScribe ColorIfTerminal stdout (permitItem InfoS) V2+--   let makeLogEnv = registerScribe "stdout" handleScribe defaultScribeSettings =<< initLogEnv \"MyApp\" \"production\" --   -- closeScribes will stop accepting new logs, flush existing ones and clean up resources---   bracket makeLogEnv closeScribes $ \le -> do+--   bracket makeLogEnv closeScribes $ \\le -> do --     let initialContext = () -- this context will be attached to every log in your app and merged w/ subsequent contexts --     let initialNamespace = "main" --     runKatipContextT le initialContext initialNamespace $ do@@ -27,6 +29,14 @@ -- -- @ --+-- And here is the output:+--+-- @+-- [2021-06-14 20:24:24][MyApp.main][Info][yourhostname][PID 14420][ThreadId 27][main:Main app/Main.hs:26:9] Hello Katip+-- [2021-06-14 20:24:24][MyApp.main.additional_namespace][Warning][yourhostname][PID 14420][ThreadId 27][some_context:True][main:Main app/Main.hs:29:11] Now we're getting fancy+--+-- @+-- -- Another common case that you have some sort of App monad that's -- based on ReaderT with some Config state. This is a perfect place to -- insert read-only katip state:@@ -44,7 +54,7 @@ -- -- newtype App m a = App { --   unApp :: ReaderT Config m a--- } deriving (Functor, Applicative, Monad) -- more instances as needed+-- } deriving (Functor, Applicative, Monad, MonadIO, MonadReader Config) -- these are necessary -- -- -- -- These instances get even easier with lenses!@@ -94,192 +104,206 @@ -- unsupported format or service. If you think it would be useful to -- others, consider releasing your own package. module Katip-    (--    -- * Framework Types-      Namespace (..)-    , Environment (..)-    , Severity (..)-    , renderSeverity-    , textToSeverity-    , Verbosity (..)-    , ToObject (..)-    , LogItem (..)-    , Item(..)-    , ThreadIdText(..)-    , PayloadSelection (..)-    , Scribe (..)-    , LogEnv (..)-    , SimpleLogPayload, sl-    , defaultScribeSettings-    , ScribeSettings-    , scribeBufferSize-    , _scribeBufferSize+  ( -- * Framework Types+    Namespace (..),+    Environment (..),+    Severity (..),+    renderSeverity,+    textToSeverity,+    Verbosity (..),+    ToObject (..),+    LogItem (..),+    Item (..),+    ThreadIdText (..),+    PayloadSelection (..),+    Scribe (..),+    LogEnv (..),+    SimpleLogPayload,+    sl,+    defaultScribeSettings,+    ScribeSettings,+    scribeBufferSize,+    _scribeBufferSize,      -- ** @lens@-compatible Lenses-    , itemApp-    , itemEnv-    , itemSeverity-    , itemThread-    , itemHost-    , itemProcess-    , itemPayload-    , itemMessage-    , itemTime-    , itemNamespace-    , itemLoc-    , logEnvHost-    , logEnvPid-    , logEnvApp-    , logEnvEnv-    , logEnvTimer-    , logEnvScribes+    itemApp,+    itemEnv,+    itemSeverity,+    itemThread,+    itemHost,+    itemProcess,+    itemPayload,+    itemMessage,+    itemTime,+    itemNamespace,+    itemLoc,+    logEnvHost,+    logEnvPid,+    logEnvApp,+    logEnvEnv,+    logEnvTimer,+    logEnvScribes,      -- * A Built-in Monad For Simple Logging-    , KatipT (..)-    , runKatipT+    KatipT (..),+    runKatipT,      -- * Initializing Loggers-    , initLogEnv-    , registerScribe+    initLogEnv,+    registerScribe,+     -- * Dropping scribes temporarily-    , unregisterScribe-    , clearScribes+    unregisterScribe,+    clearScribes,+     -- * Finalizing scribes at shutdown-    , closeScribes-    , closeScribe+    closeScribes,+    closeScribe,      -- * Logging Functions-    , LogStr (..)-    , logStr, ls, showLS+    LogStr (..),+    logStr,+    ls,+    showLS, -    -- ** 'Katip' LoggingFunctions+    -- ** 'Katip' Logging Functions     -- $katiplogging-    , Katip (..)-    , logF-    , logMsg-    , logT-    , logItem-    , logException+    Katip (..),+    logF,+    logMsg,+    logT,+    logLoc,+    logItem,+    logKatipItem,+    logException,+     -- ** 'KatipContext': Logging With Context     -- $katipcontextlogging-    , KatipContext (..)-    , logFM-    , logTM-    , logItemM-    , logExceptionM-    , AnyLogContext-    , LogContexts, liftPayload+    KatipContext (..),+    logFM,+    logTM,+    logLocM,+    logItemM,+    logExceptionM,+    AnyLogContext,+    LogContexts,+    liftPayload,+     -- *** Temporarily Changing Logging Behavior-    , katipAddNamespace-    , katipAddContext-    , katipNoLogging+    katipAddNamespace,+    katipAddContext,+    katipNoLogging,      -- * Included Scribes-    , mkHandleScribe-    , mkFileScribe-    , ColorStrategy (..)+    mkHandleScribe,+    mkHandleScribeWithFormatter,+    mkFileScribe,+    ColorStrategy (..),+    ItemFormatter,+    bracketFormat,+    jsonFormat,      -- * Tools for implementing Scribes-    , permitItem-    , payloadObject-    , itemJson+    PermitFunc,+    permitAND,+    permitOR,+    permitItem,+    payloadObject,+    itemJson,      -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances-    , KatipContextT-    , runKatipContextT-    ) where+    KatipContextT,+    runKatipContextT,+  )+where  --------------------------------------------------------------------------------import           Katip.Core-import           Katip.Monadic-import           Katip.Scribes.Handle-----------------------------------------------------------------------------------{- $katiplogging--   These logging functions use the basic 'Katip' constraint and thus-will require varying degrees of explicit detail such as 'Namespace'-and individual log items to be passed in. These can be described as-the primitives of Katip logging. If you find yourself making multiple-log statements within a logical logging context for your app, you may-want to look into the 'KatipContext' family of logging functions like-'logFM' and 'logTM'. 'KatipContext' in most applications should be-considered the default. Here's an example of the pain point:--@-doDatabaseThings = do-  connId <- getConnectionId-  logF (ConnectionIDContext connId) "database" InfoS "Doing database stuff"-  \-\- ...-  logF (ConnectionIDContext connId) "database" InfoS "Wow, passing in the same context is getting tedious"-@--Another pain point to look out for is nesting actions that log in-each other. Let's say you were writing a web app. You want to capture-some detail such as the user's ID in the logs, but you also want that-info to show up in doDatabaseThings' logs so you can associate those-two pieces of information:---@-webRequestHandler = do-  uid <- getUserId-  logF (UserIDContext uid) "web" InfoS "Starting web request"-  doDatabaseThings-@--In the above example, doDatabaseThings would overwrite that-UserIDContext with its own context and namespace. Sometimes this is-what you want and that's why 'logF' and other functions which only-require 'Katip' exist. If you are interested in combining log-contexts and namespaces, see 'KatipContext'.--}---{- $katipcontextlogging--  These logging functions use the 'KatipContext' constraint which is a-superclass of 'Katip' that also has a mechanism for keeping track of-the current context and namespace. This means a few things:--1. Functions that use 'KatipContext' like 'logFM' and 'logTM' do not-require you to pass in 'LogItem's or 'Namespaces', they pull them from-the monadic environment.--2. It becomes easy to add functions which add namespaces and/or-contexts to the current stack of them. You can (and should) make that-action scoped to a monadic action so that when it finishes, the-previous context and namespace will be automatically restored.---'KatipContextT' provides a simple, 'ReaderT'-based implementation of-the 'KatipContext' typeclass, and provides 'katipAddContext' and-'katipAddNamespace' functions to append to the context for the-duration of a block:---@-main = do-  le <- initLogEnv "MyApp" "production"-  \-\- set up scribes here-  runKatipContext le () "main" $ do-    katipAddNamespace "nextlevel" $ do-      $(logTM) InfoS "Logs here will have namespace MyApp.main.nextlevel"--    katipAddContext TrivialContext $ do-      $(logTM) InfoS "Logs here will have context from TrivialContext"+import Katip.Core+import Katip.Monadic+import Katip.Scribes.Handle -      katipAddContext AnotherContext $ do-        $(logTM) InfoS "Logs here will have context from TrivialContext *merged with* context from AnotherContext!"+------------------------------------------------------------------------------- -    $(logTM) InfoS "Log context restored to () and namespace to MyApp.main"-@+-- $katiplogging+--+--   These logging functions use the basic 'Katip' constraint and thus+-- will require varying degrees of explicit detail such as 'Namespace'+-- and individual log items to be passed in. These can be described as+-- the primitives of Katip logging. If you find yourself making multiple+-- log statements within a logical logging context for your app, you may+-- want to look into the 'KatipContext' family of logging functions like+-- 'logFM' and 'logTM'. 'KatipContext' in most applications should be+-- considered the default. Here's an example of the pain point:+--+-- @+-- doDatabaseThings = do+--  connId <- getConnectionId+--  logF (ConnectionIDContext connId) "database" InfoS "Doing database stuff"+--  \-\- ...+--  logF (ConnectionIDContext connId) "database" InfoS "Wow, passing in the same context is getting tedious"+-- @+--+-- Another pain point to look out for is nesting actions that log in+-- each other. Let's say you were writing a web app. You want to capture+-- some detail such as the user's ID in the logs, but you also want that+-- info to show up in doDatabaseThings' logs so you can associate those+-- two pieces of information:+--+--+-- @+-- webRequestHandler = do+--  uid <- getUserId+--  logF (UserIDContext uid) "web" InfoS "Starting web request"+--  doDatabaseThings+-- @+--+-- In the above example, doDatabaseThings would overwrite that+-- UserIDContext with its own context and namespace. Sometimes this is+-- what you want and that's why 'logF' and other functions which only+-- require 'Katip' exist. If you are interested in combining log+-- contexts and namespaces, see 'KatipContext'. -'katipAddNamespace' and 'katipAddContext' are one-liners, implemented-in terms of 'local' from 'MonadReader'. If you have a custom monad-transformer stack and want to add your own version of these, check out-<https://github.com/Soostone/katip/tree/master/katip/examples these-examples>.--}+-- $katipcontextlogging+--+--  These logging functions use the 'KatipContext' constraint which is a+-- superclass of 'Katip' that also has a mechanism for keeping track of+-- the current context and namespace. This means a few things:+--+-- 1. Functions that use 'KatipContext' like 'logFM' and 'logTM' do not+-- require you to pass in 'LogItem's or 'Namespaces', they pull them from+-- the monadic environment.+--+-- 2. It becomes easy to add functions which add namespaces and/or+-- contexts to the current stack of them. You can (and should) make that+-- action scoped to a monadic action so that when it finishes, the+-- previous context and namespace will be automatically restored.+--+--+-- 'KatipContextT' provides a simple, 'ReaderT'-based implementation of+-- the 'KatipContext' typeclass, and provides 'katipAddContext' and+-- 'katipAddNamespace' functions to append to the context for the+-- duration of a block:+--+--+-- @+-- main = do+--  le <- initLogEnv "MyApp" "production"+--  \-\- set up scribes here+--  runKatipContext le () "main" $ do+--    katipAddNamespace "nextlevel" $ do+--      $(logTM) InfoS "Logs here will have namespace MyApp.main.nextlevel"+--+--    katipAddContext TrivialContext $ do+--      $(logTM) InfoS "Logs here will have context from TrivialContext"+--+--      katipAddContext AnotherContext $ do+--        $(logTM) InfoS "Logs here will have context from TrivialContext *merged with* context from AnotherContext!"+--+--    $(logTM) InfoS "Log context restored to () and namespace to MyApp.main"+-- @+--+-- 'katipAddNamespace' and 'katipAddContext' are one-liners, implemented+-- in terms of 'local' from 'MonadReader'. If you have a custom monad+-- transformer stack and want to add your own version of these, check out+-- <https://github.com/Soostone/katip/tree/master/katip/examples these+-- examples>.

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveLift #-}+{-# LANGUAGE BangPatterns               #-} {-# LANGUAGE CPP                        #-} {-# LANGUAGE DefaultSignatures          #-} {-# LANGUAGE DeriveFunctor              #-}@@ -7,7 +9,6 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ImplicitParams             #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE RankNTypes                 #-}@@ -23,15 +24,18 @@ module Katip.Core where  --------------------------------------------------------------------------------import           Control.Applicative                   as A+import           Control.Applicative               as A import           Control.AutoUpdate import           Control.Concurrent-import qualified Control.Concurrent.Async              as Async+import qualified Control.Concurrent.Async          as Async import           Control.Concurrent.STM-import qualified Control.Concurrent.STM.TBQueue as BQ+import qualified Control.Concurrent.STM.TBQueue    as BQ import           Control.Exception.Safe-import           Control.Monad                         (unless, void)+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@@ -42,28 +46,41 @@ import           Control.Monad.Trans.Except import           Control.Monad.Trans.Maybe import           Control.Monad.Trans.Reader-import           Control.Monad.Trans.Resource          (ResourceT, transResourceT)-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           Control.Monad.Trans.RWS.Lazy (RWST, mapRWST)-import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)-import           Data.Aeson                   (FromJSON (..), ToJSON (..),-                                               object)-import qualified Data.Aeson                   as A-import           Data.Foldable                as FT-import qualified Data.HashMap.Strict          as HM+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.Semigroup+import qualified Data.Map.Strict                   as M+import           Data.Maybe                        (listToMaybe)+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.Text                         (Text)+import qualified Data.Text                         as T+import qualified Data.Text.Lazy                    as TL+import qualified Data.Text.Lazy.Builder            as B+import qualified Data.Text.Lazy.Builder.Int        as B import           Data.Time-import           GHC.Generics                          hiding (to)+import           GHC.Generics                      hiding (to) #if MIN_VERSION_base(4, 8, 0) #if !MIN_VERSION_base(4, 9, 0) import           GHC.SrcLoc@@ -71,7 +88,7 @@ import           GHC.Stack #endif import           Language.Haskell.TH-import qualified Language.Haskell.TH.Syntax            as TH+import qualified Language.Haskell.TH.Syntax        as TH import           Lens.Micro import           Lens.Micro.TH import           Network.HostName@@ -81,6 +98,13 @@ import           System.Posix #endif +import           GHC.Conc.Sync                     (labelThread)+#if MIN_VERSION_base(4, 19, 0)+import           GHC.Conc.Sync                     (fromThreadId)+#else+import           Data.Maybe                        (fromMaybe)+#endif+ -------------------------------------------------------------------------------  @@ -89,7 +113,10 @@               [x] -> Just x               []  -> Nothing -- no parse               _   -> Nothing -- Ambiguous parse+{-# INLINE readMay #-} +decimalToText :: Integral a => a -> Text+decimalToText = TL.toStrict . B.toLazyText . B.decimal  ------------------------------------------------------------------------------- -- | Represents a heirarchy of namespaces going from general to@@ -98,7 +125,7 @@ -- IsString/OverloadedStrings, so "foo" will result in Namespace -- ["foo"]. newtype Namespace = Namespace { unNamespace :: [Text] }-  deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,Semigroup,Monoid)+  deriving (Eq,Show,Read,Ord,Generic,ToJSON,FromJSON,SG.Semigroup,Monoid,TH.Lift)  instance IsString Namespace where     fromString s = Namespace [fromString s]@@ -108,6 +135,7 @@ -- | Ready namespace for emission with dots to join the segments. intercalateNs :: Namespace -> [Text] intercalateNs (Namespace xs) = intersperse "." xs+{-# INLINE intercalateNs #-}   -------------------------------------------------------------------------------@@ -126,7 +154,7 @@     | CriticalS                -- ^ Severe situations     | AlertS                   -- ^ Take immediate action     | EmergencyS               -- ^ System is unusable-  deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded)+  deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded, TH.Lift)   -------------------------------------------------------------------------------@@ -138,12 +166,13 @@ -- - '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 (Eq, Ord, Show, Read, Generic, Enum)+  deriving (Eq, Ord, Show, Read, Generic, Enum, Bounded, TH.Lift)   -------------------------------------------------------------------------------+{-# INLINE renderSeverity #-} renderSeverity :: Severity -> Text-renderSeverity s = case s of+renderSeverity !s = case s of       DebugS     -> "Debug"       InfoS      -> "Info"       NoticeS    -> "Notice"@@ -155,6 +184,7 @@   -------------------------------------------------------------------------------+{-# INLINE textToSeverity #-} textToSeverity :: Text -> Maybe Severity textToSeverity = go . T.toLower   where@@ -179,7 +209,22 @@           Just x  -> return x           Nothing -> fail $ "Invalid Severity " ++ toS t +instance ToJSON Verbosity where+    toJSON s = A.String $ case s of+      V0 -> "V0"+      V1 -> "V1"+      V2 -> "V2"+      V3 -> "V3" +instance FromJSON Verbosity where+    parseJSON = A.withText "Verbosity" $ \s -> case s of+      "V0" -> return V0+      "V1" -> return V1+      "V2" -> return V2+      "V3" -> return V3+      _    -> fail $ "Invalid Verbosity " ++ toS s++ ------------------------------------------------------------------------------- -- | Log message with Builder underneath; use '<>' to concat in O(1). newtype LogStr = LogStr { unLogStr :: B.Builder }@@ -191,11 +236,13 @@  instance Semigroup LogStr where   (LogStr a) <> (LogStr b) = LogStr (a <> b)+  {-# INLINE (<>) #-}   instance Monoid LogStr where     mappend = (<>)     mempty = LogStr mempty+    {-# INLINE mempty #-}   instance FromJSON LogStr where@@ -209,18 +256,21 @@ -- lazy variants. logStr :: StringConv a Text => a -> LogStr logStr t = LogStr (B.fromText $ toS t)+{-# INLINE logStr #-}   ------------------------------------------------------------------------------- -- | Shorthand for 'logStr' ls :: StringConv a Text => a -> LogStr ls = logStr+{-# INLINE ls #-}   ------------------------------------------------------------------------------- -- | Convert any showable type into a 'LogStr'. showLS :: Show a => a -> LogStr showLS = ls . show+{-# INLINE showLS #-}   -------------------------------------------------------------------------------@@ -230,15 +280,21 @@   mkThreadIdText :: ThreadId -> ThreadIdText-mkThreadIdText = ThreadIdText . T.pack . show-+#if MIN_VERSION_base(4, 19, 0)+mkThreadIdText = ThreadIdText . decimalToText . fromThreadId+#else+mkThreadIdText = ThreadIdText . stripPrefix' "ThreadId " . T.pack . show+  where+    stripPrefix' pfx t = fromMaybe t (T.stripPrefix pfx t)+#endif+{-# INLINE mkThreadIdText #-}  ------------------------------------------------------------------------------- -- | This has everything each log message will contain. data Item a = Item {       _itemApp       :: Namespace     , _itemEnv       :: Environment-    , _itemSeverity  :: Severity+    , _itemSeverity  :: {-# UNPACK #-} !Severity     , _itemThread    :: ThreadIdText     , _itemHost      :: HostName     , _itemProcess   :: ProcessID@@ -366,11 +422,13 @@   processIDToText :: ProcessID -> Text-processIDToText = toS . show+processIDToText = decimalToText+{-# INLINE processIDToText #-}   textToProcessID :: Text -> Maybe ProcessID textToProcessID = readMay . toS+{-# INLINE textToProcessID #-}   newtype ProcessIDJs = ProcessIDJs {@@ -408,6 +466,14 @@     mappend = (<>)  +-- | Compares two payload selections for equivalence. With SomeKeys, ordering+-- and duplicates are ignored.+equivalentPayloadSelection :: PayloadSelection -> PayloadSelection -> Bool+equivalentPayloadSelection AllKeys AllKeys = True+equivalentPayloadSelection (SomeKeys a) (SomeKeys b) = Set.fromList a == Set.fromList b+equivalentPayloadSelection _ _ = False+{-# INLINE equivalentPayloadSelection #-}+ ------------------------------------------------------------------------------- -- | Katip requires JSON objects to be logged as context. This -- typeclass provides a default instance which uses ToJSON and@@ -466,10 +532,21 @@ -- Construct using 'sl' and combine multiple tuples using '<>' from -- 'Monoid'. instance ToJSON SimpleLogPayload where-    toJSON (SimpleLogPayload as) = object $ map go as+    toJSON (SimpleLogPayload as) = object $ map go as'       where go (k, AnyLogPayload v) = k A..= v+            as' = toKey <$> as  +#if MIN_VERSION_aeson(2, 0, 0)+toKey :: (Text, c) -> (K.Key, c)+toKey = first K.fromText+#else+toKey :: a -> a+toKey = id+#endif+{-# INLINE toKey #-}++ instance ToObject SimpleLogPayload  @@ -491,6 +568,7 @@ -- | Construct a simple log from any JSON item. sl :: ToJSON a => Text -> a -> SimpleLogPayload sl a b = SimpleLogPayload [(a, AnyLogPayload b)]+{-# INLINE sl #-}   -------------------------------------------------------------------------------@@ -499,15 +577,26 @@ payloadObject :: LogItem a => Verbosity -> a -> A.Object payloadObject verb a = case FT.foldMap (flip payloadKeys a) [(V0)..verb] of     AllKeys     -> toObject a-    SomeKeys ks -> HM.filterWithKey (\ k _ -> k `FT.elem` ks) $ toObject a+    SomeKeys ks -> filterElems ks $ toObject a+{-# INLINE payloadObject #-} +#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 ks = HM.filterWithKey (\ k _ -> k `FT.elem` ks)+#endif+{-# INLINE filterElems #-} + ------------------------------------------------------------------------------- -- | 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 verb a = toJSON $ a & itemPayload %~ payloadObject verb+{-# INLINE itemJson #-}   -------------------------------------------------------------------------------@@ -518,52 +607,98 @@ -- -- Scribes should always take a 'Severity' and 'Verbosity'. ----- Severity is used to *exclude log messages* that are < the provided--- Severity. For instance, if the user passes InfoS, DebugS items--- should be ignored. Katip provides the 'permitItem' utility for this.+-- 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 permitted.------ There is no built-in mechanism in katip for telling a scribe that--- its time to shut down. 'unregisterScribe' merely drops it from the--- 'LogEnv'. This means there are 2 ways to handle resources as a scribe:+-- that should be written. ----- 1. Pass in the resource when the scribe is created. Handle--- allocation and release of the resource elsewhere. This is what the--- Handle scribe does.+-- 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. ----- 2. Return a finalizing function that tells the scribe to shut--- down. @katip-elasticsearch@'s @mkEsScribe@ returns an @IO (Scribe,--- IO ())@. The finalizer will flush any queued log messages and shut--- down gracefully before returning. This can be hooked into your--- application's shutdown routine to ensure you never miss any log--- messages on shutdown.+-- 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 f1 f2 = \a -> liftA2 (&&) (f1 a) (f2 a)+{-# INLINE permitAND #-}++-- | OR together 2 permit functions+permitOR :: PermitFunc -> PermitFunc -> PermitFunc+permitOR f1 f2 = \a -> liftA2 (||) (f1 a) (f2 a)+{-# INLINE permitOR #-}++ data Scribe = Scribe {-     liPush          :: forall a. LogItem a => Item a -> IO ()-   , scribeFinalizer :: IO ()-   -- ^ Provide a *blocking* finalizer to call when your scribe is-   -- removed. If this is not relevant to your scribe, return () is-   -- fine.+     liPush           :: forall a. LogItem a => Item a -> IO ()+   -- ^ How do we write an item to the scribe's output?+   , 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.+   , 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 mbool = (>>=) mbool . flip when+{-# INLINE whenM #-}++-- | 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 pushA finA) <> (Scribe pushB finB) =-    Scribe (\item -> pushA item >> pushB item) (finA `finally` finB)+  (Scribe pushA finA permitA) <> (Scribe pushB finB permitB) =+    Scribe (\item -> whenM (permitA item) (pushA item)+                  >> whenM (permitB item) (pushB item)+           )+           (finA `finally` finB)+           (permitOR permitA permitB)+  {-# INLINE (<>) #-}   instance Monoid Scribe where-    mempty = Scribe (const (return ())) (return ())+    mempty = Scribe (const (return ())) (return ()) (permitItem DebugS)+    {-# INLINE mempty #-}     mappend = (<>)   ------------------------------------------------------------------------------- data ScribeHandle = ScribeHandle {       shScribe :: Scribe-    , shChan :: BQ.TBQueue WorkerMessage+    , shChan   :: BQ.TBQueue WorkerMessage     }  @@ -575,8 +710,10 @@  ------------------------------------------------------------------------------- -- | Should this item be logged given the user's maximum severity?-permitItem :: Severity -> Item a -> Bool-permitItem sev i = _itemSeverity i >= sev+-- Most new scribes will use this as a base for their 'PermitFunc'+permitItem :: Monad m => Severity -> Item a -> m Bool+permitItem sev item = return (_itemSeverity item >= sev)+{-# INLINE permitItem #-}   -------------------------------------------------------------------------------@@ -601,7 +738,7 @@   ---------------------------------------------------------------------------------- | Create a reasonable default InitLogEnv. Uses an 'AutoUdate' which+-- | 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'.@@ -618,11 +755,14 @@   <*> pure env   <*> mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime, updateFreq = 1000 }   <*> pure mempty+{-# INLINE initLogEnv#-}   ------------------------------------------------------------------------------- -- | Add a scribe to the list. All future log calls will go to this--- scribe in addition to the others.+-- 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@@ -631,7 +771,7 @@     -> LogEnv     -> IO LogEnv registerScribe nm scribe ScribeSettings {..} le = do-  queue <- atomically (BQ.newTBQueue _scribeBufferSize)+  queue <- atomically (BQ.newTBQueue (fromIntegral _scribeBufferSize))   worker <- spawnScribeWorker scribe queue   let fin = do         atomically (BQ.writeTBQueue queue PoisonPill)@@ -642,11 +782,14 @@    let sh = ScribeHandle (scribe { scribeFinalizer = fin }) queue   return (le & logEnvScribes %~ M.insert nm sh)+{-# INLINE registerScribe#-}   ------------------------------------------------------------------------------- spawnScribeWorker :: Scribe -> BQ.TBQueue WorkerMessage -> IO (Async.Async ())-spawnScribeWorker (Scribe write _) queue = Async.async go+spawnScribeWorker (Scribe write _ _) queue = Async.async $ do+    myThreadId >>= flip labelThread "Scribe worker (katip)"+    go   where     go = do       newCmd <- atomically (BQ.readTBQueue queue)@@ -657,7 +800,7 @@           void (tryAny (write a))           go         PoisonPill -> return ()-+{-# INLINE spawnScribeWorker #-}  ------------------------------------------------------------------------------- data ScribeSettings = ScribeSettings {@@ -675,7 +818,7 @@   ---------------------------------------------------------------------------------- | Remove a scribe from the environment. This does *not* finalize+-- | 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.@@ -688,7 +831,7 @@   ---------------------------------------------------------------------------------- | Unregister *all* scribes. Note that this is *not* for closing or+-- | 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.@@ -700,9 +843,10 @@  ------------------------------------------------------------------------------- -- | Finalize a scribe. The scribe is removed from the environment,--- its finalizer is called and it can never be written to again. 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.+-- 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@@ -752,59 +896,81 @@  instance Katip m => Katip (ReaderT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapReaderT . localLogEnv+    {-# INLINE localLogEnv #-}   #if !MIN_VERSION_either(4, 5, 0) instance Katip m => Katip (EitherT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapEitherT . localLogEnv+    {-# INLINE localLogEnv #-} #endif   instance Katip m => Katip (ExceptT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapExceptT . localLogEnv+    {-# INLINE localLogEnv #-}   instance Katip m => Katip (MaybeT m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapMaybeT . localLogEnv+    {-# INLINE localLogEnv #-}   instance Katip m => Katip (StateT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapStateT . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m, Monoid w) => Katip (RWST r w s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapRWST . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m, Monoid w) => Katip (Strict.RWST r w s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = Strict.mapRWST . localLogEnv+    {-# INLINE localLogEnv #-}   instance Katip m => Katip (Strict.StateT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = Strict.mapStateT . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m, Monoid s) => Katip (WriterT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = mapWriterT . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m, Monoid s) => Katip (Strict.WriterT s m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = Strict.mapWriterT . localLogEnv+    {-# INLINE localLogEnv #-}   instance (Katip m) => Katip (ResourceT m) where     getLogEnv = lift getLogEnv+    {-# INLINE getLogEnv #-}     localLogEnv = transResourceT . localLogEnv+    {-# INLINE localLogEnv #-}   -------------------------------------------------------------------------------@@ -813,7 +979,8 @@ -- opposed to implementing 'Katip' for your monad. newtype KatipT m a = KatipT { unKatipT :: ReaderT LogEnv m a }   deriving ( Functor, Applicative, Monad, MonadIO-           , MonadMask, MonadCatch, MonadThrow, MonadTrans, MonadBase b)+           , MonadMask, MonadCatch, MonadThrow, MonadResource, MonadTrans+           , MonadBase b)   instance MonadIO m => Katip (KatipT m) where@@ -835,14 +1002,26 @@   restoreM = defaultRestoreM  instance MonadUnliftIO m => MonadUnliftIO (KatipT m) where+#if MIN_VERSION_unliftio_core(0, 2, 0)+  withRunInIO inner = KatipT $ ReaderT $ \le -> withRunInIO $ \run ->+    inner (run . runKatipT le)+#else   askUnliftIO = KatipT $-                withUnliftIO $ \u ->-                pure (UnliftIO (unliftIO u . unKatipT))+    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 msg = lift (MF.fail msg)+    {-# INLINE fail #-}+#endif+ ------------------------------------------------------------------------------- -- | Execute 'KatipT' on a log env. runKatipT :: LogEnv -> KatipT m a -> m a runKatipT le (KatipT f) = runReaderT f le+{-# INLINE runKatipT #-}   -------------------------------------------------------------------------------@@ -869,21 +1048,34 @@     -> m () logItem a ns loc sev msg = do     LogEnv{..} <- getLogEnv-    liftIO $ do-      item <- Item-        <$> pure _logEnvApp-        <*> pure _logEnvEnv-        <*> pure sev-        <*> (mkThreadIdText <$> myThreadId)-        <*> pure _logEnvHost-        <*> pure _logEnvPid-        <*> pure a-        <*> pure msg-        <*> _logEnvTimer-        <*> pure (_logEnvApp <> ns)-        <*> pure loc-      FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> atomically (tryWriteTBQueue shChan (NewItem item))+    logKatipItem =<< liftIO+      (Item <$> pure _logEnvApp+            <*> pure _logEnvEnv+            <*> pure sev+            <*> (mkThreadIdText <$> myThreadId)+            <*> pure _logEnvHost+            <*> pure _logEnvPid+            <*> pure a+            <*> pure msg+            <*> _logEnvTimer+            <*> pure (_logEnvApp <> ns)+            <*> pure loc)+{-# INLINE logItem#-} +-- | 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 = do+    LogEnv{..} <- getLogEnv+    liftIO $+      FT.forM_ (M.elems _logEnvScribes) $ \ ScribeHandle {..} -> do+        whenM (scribePermitItem shScribe item) $+          void $ atomically (tryWriteTBQueue shChan (NewItem item))+{-# INLINE logKatipItem#-}  ------------------------------------------------------------------------------- tryWriteTBQueue@@ -895,7 +1087,9 @@   full <- isFullTBQueue q   unless full (writeTBQueue q a)   return (not full)+{-# INLINE tryWriteTBQueue#-} + ------------------------------------------------------------------------------- -- | Log with full context, but without any code location. logF@@ -910,6 +1104,7 @@   -- ^ The log message   -> m () logF a ns sev msg = logItem a ns Nothing sev msg+{-# INLINE logF#-}   @@ -928,7 +1123,7 @@ logException a ns sev action = action `catchAny` \e -> f e >> throwM e   where     f e = logF a ns sev (msg e)-    msg e = ls (T.pack "An exception has occured: ") <> showLS e+    msg e = ls (T.pack "An exception has occurred: ") <> showLS e   -------------------------------------------------------------------------------@@ -942,30 +1137,6 @@ logMsg ns sev msg = logF () ns sev msg  -instance TH.Lift Namespace where-    lift (Namespace xs) =-      let xs' = map T.unpack xs-      in  [| Namespace (map T.pack xs') |]---instance TH.Lift Verbosity where-    lift V0 = [| V0 |]-    lift V1 = [| V1 |]-    lift V2 = [| V2 |]-    lift V3 = [| V3 |]---instance TH.Lift Severity where-    lift DebugS     = [| DebugS |]-    lift InfoS      = [| InfoS |]-    lift NoticeS    = [| NoticeS |]-    lift WarningS   = [| WarningS |]-    lift ErrorS     = [| ErrorS |]-    lift CriticalS  = [| CriticalS |]-    lift AlertS     = [| AlertS |]-    lift EmergencyS = [| EmergencyS |]-- -- | Lift a location into an Exp. liftLoc :: Loc -> Q Exp liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc@@ -982,10 +1153,8 @@ -- 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 :: (?loc :: CallStack) => Maybe Loc-getLoc = case getCallStack ?loc of-  [] -> Nothing-  xs -> Just . toLoc . last $ xs+getLoc :: HasCallStack => Maybe Loc+getLoc = withFrozenCallStack $ toLoc <$> listToMaybe (getCallStack callStack)   where     toLoc :: (String, SrcLoc) -> Loc     toLoc (_, l) = Loc {@@ -1017,7 +1186,7 @@   ---------------------------------------------------------------------------------- | 'Loc'-tagged logging using implicit-callstacks when available.+-- | '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>@@ -1028,7 +1197,7 @@ -- -- @logLoc obj mempty InfoS "Hello world"@ #if MIN_VERSION_base(4, 8, 0)-logLoc :: (Applicative m, LogItem a, Katip m, ?loc :: CallStack)+logLoc :: (Applicative m, LogItem a, Katip m, HasCallStack) #else logLoc :: (Applicative m, LogItem a, Katip m) #endif@@ -1037,7 +1206,7 @@        -> Severity        -> LogStr        -> m ()-logLoc a ns = logItem a ns getLoc+logLoc a ns = withFrozenCallStack $ logItem a ns getLoc   -- taken from the file-location package

@@ -1,19 +1,25 @@+{-# LANGUAGE CPP #-}+ -- | Time and memory efficient time encoding helper functions.--- module Katip.Format.Time-    ( formatAsLogTime-    , formatAsIso8601-    ) where--import           Control.Monad.ST        (ST)+  ( formatAsLogTime,+    formatAsIso8601,+  )+where -import           Data.Int                (Int64)-import qualified Data.Text.Array         as TA-import           Data.Text               (Text)-import           Data.Text.Internal      (Text(..))-import           Data.Time               (UTCTime(..), toGregorian, Day, DiffTime)-import           Data.Word               (Word16)-import           Unsafe.Coerce           (unsafeCoerce)+import Control.Monad.ST (ST)+import Data.Int (Int64)+import Data.Text (Text)+import qualified Data.Text.Array as TA+import Data.Text.Internal (Text (..))+import Data.Time (Day, DiffTime, UTCTime (..), toGregorian)+import Data.Word+#if MIN_VERSION_text(2,0,0)+  (Word8)+#else+  (Word16)+#endif+import Unsafe.Coerce (unsafeCoerce)  -- Note: All functions here are optimized to never allocate anything -- on heap. At least on ghc 8.0.1 no extra strictness annotations are@@ -21,23 +27,21 @@ -- -- Exported functions are INLINEABLE - -- | Format 'UTCTime' into a short human readable format. -- -- >>> formatAsLogTime $ UTCTime (fromGregorian 2016 1 23) 5025.123456789012 -- "2016-01-23 01:23:45"--- formatAsLogTime :: UTCTime -> Text-formatAsLogTime (UTCTime day time) = toText $ TA.run2 $ do-     buf <- TA.new 19 -- length "2016-10-20 12:34:56"-     _ <- writeDay buf 0 day-     TA.unsafeWrite buf 10 0x20 -- space-     _ <- writeTimeOfDay False buf 11 (diffTimeOfDay64 time)-     return (buf, 19)+formatAsLogTime (UTCTime day time) = toText $+  TA.run2 $ do+    buf <- TA.new 19 -- length "2016-10-20 12:34:56"+    _ <- writeDay buf 0 day+    TA.unsafeWrite buf 10 0x20 -- space+    _ <- writeTimeOfDay False buf 11 (diffTimeOfDay64 time)+    return (buf, 19)   where-     toText (arr, len) = Text arr 0 len--{-# INLINEABLE formatAsLogTime #-}+    toText (arr, len) = Text arr 0 len+{-# INLINE formatAsLogTime #-}  -- | Format 'UTCTime' into a Iso8601 format. --@@ -54,17 +58,17 @@  -- formatAsIso8601 :: UTCTime -> Text-formatAsIso8601 (UTCTime day time) = toText $ TA.run2 $ do-   buf <- TA.new 33 -- length "2016-10-20 12:34:56.123456789012Z"-   _ <- writeDay buf 0 day-   TA.unsafeWrite buf  10  0x54 -- T-   next <- writeTimeOfDay True buf 11 (diffTimeOfDay64 time)-   TA.unsafeWrite buf next 0x5A -- Z-   return (buf, next+1)+formatAsIso8601 (UTCTime day time) = toText $+  TA.run2 $ do+    buf <- TA.new 33 -- length "2016-10-20 12:34:56.123456789012Z"+    _ <- writeDay buf 0 day+    TA.unsafeWrite buf 10 0x54 -- T+    next <- writeTimeOfDay True buf 11 (diffTimeOfDay64 time)+    TA.unsafeWrite buf next 0x5A -- Z+    return (buf, next + 1)   where-     toText (arr, len) = Text arr 0 len--{-# INLINEABLE formatAsIso8601 #-}+    toText (arr, len) = Text arr 0 len+{-# INLINE formatAsIso8601 #-}  -- | Writes the @YYYY-MM-DD@ part of timestamp writeDay :: TA.MArray s -> Int -> Day -> ST s Int@@ -82,20 +86,19 @@     TA.unsafeWrite buf (off + 9) d2     return (off + 10)   where-    (yr,m,d) = toGregorian day+    (yr, m, d) = toGregorian day     (y1, ya) = fromIntegral (abs yr) `quotRem` 1000     (y2, yb) = ya `quotRem` 100     (y3, y4) = yb `quotRem` 10-    T m1 m2  = twoDigits m-    T d1 d2  = twoDigits d+    T m1 m2 = twoDigits m+    T d1 d2 = twoDigits d {-# INLINE writeDay #-}  -- | Write time of day, optionally with sub seconds writeTimeOfDay :: Bool -> TA.MArray s -> Int -> TimeOfDay64 -> ST s Int writeTimeOfDay doSubSeconds buf off (TOD hh mm ss) =   do--    TA.unsafeWrite buf  off      h1+    TA.unsafeWrite buf off h1     TA.unsafeWrite buf (off + 1) h2     TA.unsafeWrite buf (off + 2) 0x3A -- colon     TA.unsafeWrite buf (off + 3) m1@@ -104,52 +107,49 @@     TA.unsafeWrite buf (off + 6) s1     TA.unsafeWrite buf (off + 7) s2     if doSubSeconds && frac /= 0-    then writeFracSeconds buf (off + 8) frac-    else return (off + 8)+      then writeFracSeconds buf (off + 8) frac+      else return (off + 8)   where-   T h1 h2 = twoDigits hh-   T m1 m2 = twoDigits mm-   T s1 s2 = twoDigits (fromIntegral real)-   (real,frac) = ss `quotRem` pico-   pico       = 1000000000000 -- number of picoseconds  in 1 second-+    T h1 h2 = twoDigits hh+    T m1 m2 = twoDigits mm+    T s1 s2 = twoDigits (fromIntegral real)+    (real, frac) = ss `quotRem` pico+    pico = 1000000000000 -- number of picoseconds  in 1 second+{-# INLINE writeTimeOfDay #-}  writeFracSeconds :: TA.MArray s -> Int -> Int64 -> ST s Int writeFracSeconds buf off frac =   do     TA.unsafeWrite buf off 0x2e -- period     if mills == 0-    then do-      writeTrunc6 buf (off + 1) (fromIntegral mics)-    else do-      writeDigit6 buf (off + 1) (fromIntegral mics)-      writeTrunc6 buf (off + 7) (fromIntegral mills)-+      then do+        writeTrunc6 buf (off + 1) (fromIntegral mics)+      else do+        writeDigit6 buf (off + 1) (fromIntegral mics)+        writeTrunc6 buf (off + 7) (fromIntegral mills)   where-    (mics, mills)  = frac `quotRem` micro-    micro          = 1000000 -- number of microseconds in 1 second-+    (mics, mills) = frac `quotRem` micro+    micro = 1000000 -- number of microseconds in 1 second+{-# INLINE writeFracSeconds #-}  writeDigit6 :: TA.MArray s -> Int -> Int -> ST s () writeDigit6 buf off i =   do     writeDigit3 buf off f1-    writeDigit3 buf (off+3) f2+    writeDigit3 buf (off + 3) f2   where-   (f1, f2) = i `quotRem` 1000-+    (f1, f2) = i `quotRem` 1000 {-# INLINE writeDigit6 #-}  writeDigit3 :: TA.MArray s -> Int -> Int -> ST s () writeDigit3 buf off i =   do     TA.unsafeWrite buf off (digit d1)-    TA.unsafeWrite buf (off+1) (digit d2)-    TA.unsafeWrite buf (off+2) (digit d3)+    TA.unsafeWrite buf (off + 1) (digit d2)+    TA.unsafeWrite buf (off + 2) (digit d3)   where     (d1, d) = i `quotRem` 100     (d2, d3) = d `quotRem` 10- {-# INLINE writeDigit3 #-}  writeTrunc6 :: TA.MArray s -> Int -> Int -> ST s Int@@ -158,56 +158,64 @@     then writeTrunc3 buf off f1     else do       writeDigit3 buf off f1-      writeTrunc3 buf (off+3) f2+      writeTrunc3 buf (off + 3) f2   where-   (f1, f2) = i `quotRem` 1000-+    (f1, f2) = i `quotRem` 1000 {-# INLINE writeTrunc6 #-} - writeTrunc3 :: TA.MArray s -> Int -> Int -> ST s Int writeTrunc3 buf off i-    | d == 0 = do-        TA.unsafeWrite buf off (digit d1)-        return (off+1)-    | d3 == 0 = do-        TA.unsafeWrite buf off (digit d1)-        TA.unsafeWrite buf (off+1) (digit d2)-        return (off+2)--    | otherwise = do-        TA.unsafeWrite buf off (digit d1)-        TA.unsafeWrite buf (off+1) (digit d2)-        TA.unsafeWrite buf (off+2) (digit d3)-        return (off+3)+  | d == 0 = do+    TA.unsafeWrite buf off (digit d1)+    return (off + 1)+  | d3 == 0 = do+    TA.unsafeWrite buf off (digit d1)+    TA.unsafeWrite buf (off + 1) (digit d2)+    return (off + 2)+  | otherwise = do+    TA.unsafeWrite buf off (digit d1)+    TA.unsafeWrite buf (off + 1) (digit d2)+    TA.unsafeWrite buf (off + 2) (digit d3)+    return (off + 3)   where     (d1, d) = i `quotRem` 100     (d2, d3) = d `quotRem` 10- {-# INLINE writeTrunc3 #-} - -- Following code was adapted from aeson package. -- -- Copyright:   (c) 2015-2016 Bryan O'Sullivan -- License:     BSD3 -data T = T {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16+data T = T+#if MIN_VERSION_text(2,0,0)+  {-# UNPACK #-} !Word8 {-# UNPACK #-} !Word8+#else+  {-# UNPACK #-} !Word16 {-# UNPACK #-} !Word16+#endif  twoDigits :: Int -> T-twoDigits a     = T (digit hi) (digit lo)-  where (hi,lo) = a `quotRem` 10+twoDigits a = T (digit hi) (digit lo)+  where+    (hi, lo) = a `quotRem` 10 -digit :: Int -> Word16+digit :: Int ->+#if MIN_VERSION_text(2,0,0)+  Word8+#else+  Word16+#endif digit x = fromIntegral (x + 48) --data TimeOfDay64 = TOD {-# UNPACK #-} !Int-                       {-# UNPACK #-} !Int-                       {-# UNPACK #-} !Int64+data TimeOfDay64+  = TOD+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int+      {-# UNPACK #-} !Int64  diffTimeOfDay64 :: DiffTime -> TimeOfDay64 diffTimeOfDay64 t = TOD (fromIntegral h) (fromIntegral m) s-  where (h,mp) = fromIntegral pico `quotRem` 3600000000000000-        (m,s)  = mp `quotRem` 60000000000000-        pico   = unsafeCoerce t :: Integer+  where+    (h, mp) = fromIntegral pico `quotRem` 3600000000000000+    (m, s) = mp `quotRem` 60000000000000+    pico = unsafeCoerce t :: Integer

@@ -1,86 +1,112 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses      #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeFamilies               #-}-{-# LANGUAGE UndecidableInstances       #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+ #if MIN_VERSION_base(4, 9, 0) {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif+ -- | Provides support for treating payloads and namespaces as -- composable contexts. The common pattern would be to provide a -- 'KatipContext' instance for your base monad. module Katip.Monadic-    (-    -- * Monadic variants of logging functions from "Katip.Core"-      logFM-    , logTM-    , logLocM-    , logItemM-    , logExceptionM+  ( -- * Monadic variants of logging functions from "Katip.Core"+    logFM,+    logTM,+    logLocM,+    logItemM,+    logExceptionM,      -- * Machinery for merging typed log payloads/contexts-    , KatipContext(..)-    , AnyLogContext-    , LogContexts-    , liftPayload+    KatipContext (..),+    AnyLogContext,+    LogContexts,+    liftPayload,      -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances-    , KatipContextT(..)-    , runKatipContextT-    , katipAddNamespace-    , katipAddContext-    , KatipContextTState(..)-    , NoLoggingT (..)-    , askLoggerIO-    ) where-+    KatipContextT (..),+    runKatipContextT,+    katipAddNamespace,+    katipAddContext,+    KatipContextTState (..),+    NoLoggingT (..),+    askLoggerIO,+  )+where  --------------------------------------------------------------------------------import           Control.Applicative-import           Control.Exception.Safe-import           Control.Monad.Base-import           Control.Monad.Error.Class-import           Control.Monad.IO.Class-import           Control.Monad.IO.Unlift-import           Control.Monad.Reader-import           Control.Monad.State-import           Control.Monad.Trans.Control+import Control.Applicative+import Control.Exception.Safe+import Control.Monad                               as CM+import Control.Monad.Base+import Control.Monad.Error.Class+#if MIN_VERSION_base(4, 9, 0)+import qualified Control.Monad.Fail                as MF+#endif+import Control.Monad.Fix                           as MFix+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Trans.Control #if !MIN_VERSION_either(4, 5, 0) import           Control.Monad.Trans.Either        (EitherT, mapEitherT) #endif-import           Control.Monad.Trans.Except        (ExceptT, mapExceptT)-import           Control.Monad.Trans.Identity      (IdentityT, mapIdentityT)-import           Control.Monad.Trans.List          (ListT, mapListT)-import           Control.Monad.Trans.Maybe         (MaybeT, mapMaybeT)-import           Control.Monad.Trans.Resource      (ResourceT, transResourceT)-import           Control.Monad.Trans.RWS           (RWST, mapRWST)-import qualified Control.Monad.Trans.RWS.Strict    as Strict (RWST, mapRWST)-import qualified Control.Monad.Trans.State.Strict  as Strict (StateT, mapStateT)-import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT,-                                                              mapWriterT)-import           Control.Monad.Writer              hiding ((<>))-import           Data.Aeson-import qualified Data.Foldable                     as FT-import qualified Data.HashMap.Strict               as HM-import           Data.Semigroup                    as Semi-import           Data.Sequence                     as Seq-import           Data.Text                         (Text)-import           Language.Haskell.TH+import Control.Monad.Trans.Except (ExceptT, mapExceptT)+import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)+import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)+import Control.Monad.Trans.RWS (RWST, mapRWST)+import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)+import Control.Monad.Trans.Resource+  ( MonadResource,+    ResourceT,+    transResourceT,+  )+import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)+import qualified Control.Monad.Trans.Writer.Strict as Strict+  ( WriterT,+    mapWriterT,+  )+import qualified Control.Monad.Writer as Lazy (WriterT, mapWriterT)+import Control.Monad.Writer.Class as WC+import Data.Aeson+#if MIN_VERSION_aeson(2, 0, 0)+import qualified Data.Aeson.KeyMap as KM+import qualified Data.Aeson.Key as K+#endif+import qualified Data.Foldable as FT+#if !MIN_VERSION_aeson(2, 0, 0)+import qualified Data.HashMap.Strict as HM+#endif+import Data.Semigroup as Semi+import Data.Sequence as Seq+import Data.Text (Text)+#if MIN_VERSION_base(4, 8, 0)+#if !MIN_VERSION_base(4, 9, 0)+import           GHC.SrcLoc+#endif+import GHC.Stack+#endif+ --------------------------------------------------------------------------------import           Katip.Core+import Katip.Core+import Language.Haskell.TH+ -------------------------------------------------------------------------------  -- | A wrapper around a log context that erases type information so -- that contexts from multiple layers can be combined intelligently. data AnyLogContext where-    AnyLogContext :: (LogItem a) => a -> AnyLogContext-+  AnyLogContext :: (LogItem a) => a -> AnyLogContext  -------------------------------------------------------------------------------+ -- | Heterogeneous list of log contexts that provides a smart -- 'LogContext' instance for combining multiple payload policies. This -- is critical for log contexts deep down in a stack to be able to@@ -100,31 +126,39 @@ newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid, Semigroup)  instance ToJSON LogContexts where-    toJSON (LogContexts cs) =-      -- flip mappend to get right-biased merge-      Object $ FT.foldr (flip mappend) mempty $ fmap (\(AnyLogContext v) -> toObject v) cs+  toJSON (LogContexts cs) =+    -- flip mappend to get right-biased merge+    Object $ FT.foldr (flip mappend) mempty $ fmap (\(AnyLogContext v) -> toObject v) cs  instance ToObject LogContexts  instance LogItem LogContexts where-    payloadKeys verb (LogContexts vs) = FT.foldr (flip mappend) mempty $ fmap payloadKeys' vs-      where-        -- To ensure AllKeys doesn't leak keys from other values when-        -- combined, we resolve AllKeys to its equivalent SomeKeys-        -- representation first.-        payloadKeys' (AnyLogContext v) = case payloadKeys verb v of-          AllKeys -> SomeKeys $ HM.keys $ toObject v-          x       -> x+  payloadKeys verb (LogContexts vs) = FT.foldr (flip mappend) mempty $ fmap payloadKeys' vs+    where+      -- To ensure AllKeys doesn't leak keys from other values when+      -- combined, we resolve AllKeys to its equivalent SomeKeys+      -- representation first.+      payloadKeys' (AnyLogContext v) = case payloadKeys verb v of+        AllKeys -> SomeKeys $ toKeys $ toObject v+        x -> x +#if MIN_VERSION_aeson(2, 0, 0)+toKeys :: KM.KeyMap v -> [Text]+toKeys = fmap K.toText . KM.keys+#else+toKeys :: HM.HashMap k v -> [k]+toKeys = HM.keys+#endif  -------------------------------------------------------------------------------+ -- | Lift a log context into the generic wrapper so that it can -- combine with the existing log context. liftPayload :: (LogItem a) => a -> LogContexts liftPayload = LogContexts . Seq.singleton . AnyLogContext - -------------------------------------------------------------------------------+ -- | A monadic context that has an inherant way to get logging context -- and namespace. Examples include a web application monad or database -- monad. The @local@ variants are just like @local@ from Reader and@@ -135,10 +169,13 @@ -- own in each app. class Katip m => KatipContext m where   getKatipContext :: m LogContexts+   -- | Temporarily modify the current context for the duration of the   -- supplied monad. Used in 'katipAddContext'   localKatipContext :: (LogContexts -> LogContexts) -> m a -> m a+   getKatipNamespace :: m Namespace+   -- | Temporarily modify the current namespace for the duration of the   -- supplied monad. Used in 'katipAddNamespace'   localKatipNamespace :: (Namespace -> Namespace) -> m a -> m a@@ -149,14 +186,12 @@   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = mapIdentityT . localKatipNamespace - instance (KatipContext m, Katip (MaybeT m)) => KatipContext (MaybeT m) where   getKatipContext = lift getKatipContext   localKatipContext = mapMaybeT . localKatipContext   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = mapMaybeT . localKatipNamespace - #if !MIN_VERSION_either(4, 5, 0) instance (KatipContext m, Katip (EitherT e m)) => KatipContext (EitherT e m) where   getKatipContext = lift getKatipContext@@ -165,62 +200,47 @@   localKatipNamespace = mapEitherT . localKatipNamespace #endif --instance (KatipContext m, Katip (ListT m)) => KatipContext (ListT m) where-  getKatipContext = lift getKatipContext-  localKatipContext = mapListT . localKatipContext-  getKatipNamespace = lift getKatipNamespace-  localKatipNamespace = mapListT . localKatipNamespace-- instance (KatipContext m, Katip (ReaderT r m)) => KatipContext (ReaderT r m) where   getKatipContext = lift getKatipContext   localKatipContext = mapReaderT . localKatipContext   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = mapReaderT . localKatipNamespace - instance (KatipContext m, Katip (ResourceT m)) => KatipContext (ResourceT m) where   getKatipContext = lift getKatipContext   localKatipContext = transResourceT . localKatipContext   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = transResourceT . localKatipNamespace - instance (KatipContext m, Katip (Strict.StateT s m)) => KatipContext (Strict.StateT s m) where   getKatipContext = lift getKatipContext   localKatipContext = Strict.mapStateT . localKatipContext   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = Strict.mapStateT . localKatipNamespace - instance (KatipContext m, Katip (StateT s m)) => KatipContext (StateT s m) where   getKatipContext = lift getKatipContext   localKatipContext = mapStateT . localKatipContext   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = mapStateT . localKatipNamespace - instance (KatipContext m, Katip (ExceptT e m)) => KatipContext (ExceptT e m) where   getKatipContext = lift getKatipContext   localKatipContext = mapExceptT . localKatipContext   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = mapExceptT . localKatipNamespace - instance (Monoid w, KatipContext m, Katip (Strict.WriterT w m)) => KatipContext (Strict.WriterT w m) where   getKatipContext = lift getKatipContext   localKatipContext = Strict.mapWriterT . localKatipContext   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = Strict.mapWriterT . localKatipNamespace --instance (Monoid w, KatipContext m, Katip (WriterT w m)) => KatipContext (WriterT w m) where+instance (Monoid w, KatipContext m, Katip (Lazy.WriterT w m)) => KatipContext (Lazy.WriterT w m) where   getKatipContext = lift getKatipContext-  localKatipContext = mapWriterT . localKatipContext+  localKatipContext = Lazy.mapWriterT . localKatipContext   getKatipNamespace = lift getKatipNamespace-  localKatipNamespace = mapWriterT . localKatipNamespace-+  localKatipNamespace = Lazy.mapWriterT . localKatipNamespace  instance (Monoid w, KatipContext m, Katip (Strict.RWST r w s m)) => KatipContext (Strict.RWST r w s m) where   getKatipContext = lift getKatipContext@@ -228,95 +248,99 @@   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = Strict.mapRWST . localKatipNamespace - instance (Monoid w, KatipContext m, Katip (RWST r w s m)) => KatipContext (RWST r w s m) where   getKatipContext = lift getKatipContext   localKatipContext = mapRWST . localKatipContext   getKatipNamespace = lift getKatipNamespace   localKatipNamespace = mapRWST . localKatipNamespace - deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m)  -------------------------------------------------------------------------------+ -- | Log with everything, including a source code location. This is -- very low level and you typically can use 'logTM' in its -- place. Automatically supplies payload and namespace.-logItemM-    :: (Applicative m, KatipContext m)-    => Maybe Loc-    -> Severity-    -> LogStr-    -> m ()+logItemM ::+  (Applicative m, KatipContext m, HasCallStack) =>+  Maybe Loc ->+  Severity ->+  LogStr ->+  m () logItemM loc sev msg = do-    ctx <- getKatipContext-    ns <- getKatipNamespace-    logItem ctx ns loc sev msg-+  ctx <- getKatipContext+  ns <- getKatipNamespace+  logItem ctx ns loc sev msg  -------------------------------------------------------------------------------+ -- | Log with full context, but without any code -- location. Automatically supplies payload and namespace.-logFM-  :: (Applicative m, KatipContext m)-  => Severity-  -- ^ Severity of the message-  -> LogStr-  -- ^ The log message-  -> m ()+logFM ::+  (Applicative m, KatipContext m) =>+  -- | Severity of the message+  Severity ->+  -- | The log message+  LogStr ->+  m () logFM sev msg = do   ctx <- getKatipContext   ns <- getKatipNamespace   logF ctx ns sev msg - -------------------------------------------------------------------------------+ -- | 'Loc'-tagged logging when using template-haskell. Automatically -- supplies payload and namespace. -- -- @$(logTM) InfoS "Hello world"@ logTM :: ExpQ-logTM = [| logItemM (Just $(getLocTH)) |]-+logTM = [|logItemM (Just $(getLocTH))|]  ---------------------------------------------------------------------------------- | 'Loc'-tagged logging when using template-haskell. Automatically--- supplies payload and namespace.++-- | 'Loc'-tagged logging when using 'GHC.Stack.getCallStack' implicit-callstacks>.+--   Automatically supplies payload and namespace. -- -- Same consideration as `logLoc` applies. ----- 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+-- By default, location will be logged from the module that invokes 'logLocM'.+-- If you want to use 'logLocM' in a helper, wrap the entire helper in+-- 'withFrozenCallStack' to retain the callsite of the helper in the logs.+--+-- This function does not require template-haskell. Using GHC <= 7.8 will result+-- in the emission of a log line without any location information.+-- Users using GHC <= 7.8 may want to use the template-haskell function -- `logTM` for maximum compatibility. -- -- @logLocM InfoS "Hello world"@-logLocM :: (Applicative m, KatipContext m)-        => Severity-        -> LogStr-        -> m ()-logLocM = logItemM getLoc-+logLocM ::+  (Applicative m, KatipContext m, HasCallStack) =>+  Severity ->+  LogStr ->+  m ()+logLocM sev item = withFrozenCallStack $ logItemM getLoc sev item  -------------------------------------------------------------------------------+ -- | Perform an action while logging any exceptions that may occur. -- Inspired by 'onException`. -- -- >>>> error "foo" `logExceptionM` ErrorS-logExceptionM-    :: (KatipContext m, MonadCatch m, Applicative m)-    => m a                      -- ^ Main action to run-    -> Severity                 -- ^ Severity-    -> m a+logExceptionM ::+  (KatipContext m, MonadCatch m, Applicative m) =>+  -- | Main action to run+  m a ->+  -- | Severity+  Severity ->+  m a logExceptionM action sev = action `catchAny` \e -> f e >> throwM e   where     f e = logFM sev (msg e)-    msg e = ls ("An exception has occured: " :: Text) Semi.<> showLS e-+    msg e = ls ("An exception has occurred: " :: Text) Semi.<> showLS e  -------------------------------------------------------------------------------+ -- | Provides a simple transformer that defines a 'KatipContext' -- instance for a fixed namespace and context. Just like 'KatipT', you -- should use this if you prefer an explicit transformer stack and@@ -333,70 +357,79 @@ --       $(logTM) InfoS "Look, I can log in IO and retain context!" --       doOtherStuff -- @-newtype KatipContextT m a = KatipContextT {-      unKatipContextT :: ReaderT KatipContextTState m a-    } deriving ( Functor-               , Applicative-               , Monad-               , MonadIO-               , MonadThrow-               , MonadCatch-               , MonadMask-               , MonadBase b-               , MonadState s-               , MonadWriter w-               , MonadError e-               , MonadPlus-               , Alternative-               , MonadFix-               , MonadTrans-               )---data KatipContextTState = KatipContextTState {-      ltsLogEnv    :: !LogEnv-    , ltsContext   :: !LogContexts-    , ltsNamespace :: !Namespace-    }+newtype KatipContextT m a = KatipContextT+  { unKatipContextT :: ReaderT KatipContextTState m a+  }+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadIO,+      MonadThrow,+      MonadCatch,+      MonadMask,+      MonadBase b,+      MonadState s,+      WC.MonadWriter w,+      MonadError e,+      CM.MonadPlus,+      MonadResource,+      Alternative,+      MFix.MonadFix,+      MonadTrans+    ) +data KatipContextTState = KatipContextTState+  { ltsLogEnv :: !LogEnv,+    ltsContext :: !LogContexts,+    ltsNamespace :: !Namespace+  }  instance MonadTransControl KatipContextT where-    type StT KatipContextT a = StT (ReaderT KatipContextTState) a-    liftWith = defaultLiftWith KatipContextT unKatipContextT-    restoreT = defaultRestoreT KatipContextT-    {-# INLINE liftWith #-}-    {-# INLINE restoreT #-}-+  type StT KatipContextT a = StT (ReaderT KatipContextTState) a+  liftWith = defaultLiftWith KatipContextT unKatipContextT+  restoreT = defaultRestoreT KatipContextT+  {-# INLINE liftWith #-}+  {-# INLINE restoreT #-}  instance (MonadBaseControl b m) => MonadBaseControl b (KatipContextT m) where   type StM (KatipContextT m) a = ComposeSt KatipContextT m a   liftBaseWith = defaultLiftBaseWith   restoreM = defaultRestoreM - -- Reader is a passthrough. We don't expose our internal reader so as not to conflict instance (MonadReader r m) => MonadReader r (KatipContextT m) where-    ask = lift ask-    local f (KatipContextT (ReaderT m)) = KatipContextT $ ReaderT $ \r ->+  ask = lift ask+  local f (KatipContextT (ReaderT m)) = KatipContextT $+    ReaderT $ \r ->       local f (m r) - instance (MonadIO m) => Katip (KatipContextT m) where   getLogEnv = KatipContextT $ ReaderT $ \lts -> return (ltsLogEnv lts)-  localLogEnv f (KatipContextT m) = KatipContextT (local (\s -> s { ltsLogEnv = f (ltsLogEnv s)}) m)-+  localLogEnv f (KatipContextT m) = KatipContextT (local (\s -> s {ltsLogEnv = f (ltsLogEnv s)}) m)  instance (MonadIO m) => KatipContext (KatipContextT m) where   getKatipContext = KatipContextT $ ReaderT $ \lts -> return (ltsContext lts)-  localKatipContext f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsContext = f (ltsContext s)}) m+  localKatipContext f (KatipContextT m) = KatipContextT $ local (\s -> s {ltsContext = f (ltsContext s)}) m   getKatipNamespace = KatipContextT $ ReaderT $ \lts -> return (ltsNamespace lts)-  localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m+  localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s {ltsNamespace = f (ltsNamespace s)}) m +#if MIN_VERSION_unliftio_core(0, 2, 0) instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where+  withRunInIO inner = KatipContextT $ ReaderT $ \lts -> withRunInIO $ \run ->+    inner (run . runKatipContextT (ltsLogEnv lts) (ltsContext lts) (ltsNamespace lts))+#else+instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where   askUnliftIO = KatipContextT $-                withUnliftIO $ \u ->-                pure (UnliftIO (unliftIO u . unKatipContextT))+    withUnliftIO $ \u ->+      pure (UnliftIO (unliftIO u . unKatipContextT))+#endif +#if MIN_VERSION_base(4, 9, 0)+instance MF.MonadFail m => MF.MonadFail (KatipContextT m) where+    fail msg = lift (MF.fail msg)+    {-# INLINE fail #-}+#endif  ------------------------------------------------------------------------------- runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a -> m a@@ -404,20 +437,20 @@   where     lts = KatipContextTState le (liftPayload ctx) ns - -------------------------------------------------------------------------------+ -- | Append a namespace segment to the current namespace for the given -- monadic action, then restore the previous state -- afterwards. Works with anything implementing KatipContext.-katipAddNamespace-    :: (KatipContext m)-    => Namespace-    -> m a-    -> m a+katipAddNamespace ::+  (KatipContext m) =>+  Namespace ->+  m a ->+  m a katipAddNamespace ns = localKatipNamespace (<> ns) - -------------------------------------------------------------------------------+ -- | Append some context to the current context for the given monadic -- action, then restore the previous state afterwards. Important note: -- be careful using this in a loop. If you're using something like@@ -429,55 +462,65 @@ -- redundant contexts and even if they all merge on log, they are -- stored in a sequence and will leak memory. Works with anything -- implementing KatipContext.-katipAddContext-    :: ( LogItem i-       , KatipContext m-       )-    => i-    -> m a-    -> m a+katipAddContext ::+  ( LogItem i,+    KatipContext m+  ) =>+  i ->+  m a ->+  m a katipAddContext i = localKatipContext (<> (liftPayload i)) -newtype NoLoggingT m a = NoLoggingT {-      runNoLoggingT :: m a-    } deriving ( Functor-               , Applicative-               , Monad-               , MonadIO-               , MonadThrow-               , MonadCatch-               , MonadMask-               , MonadBase b-               , MonadState s-               , MonadWriter w-               , MonadError e-               , MonadPlus-               , Alternative-               , MonadFix-               , MonadReader r-               )+newtype NoLoggingT m a = NoLoggingT+  { runNoLoggingT :: m a+  }+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadIO,+      MonadThrow,+      MonadCatch,+      MonadMask,+      MonadBase b,+      MonadState s,+      WC.MonadWriter w,+      MonadError e,+      CM.MonadPlus,+      Alternative,+      MFix.MonadFix,+      MonadReader r+    )  instance MonadTrans NoLoggingT where   lift = NoLoggingT  instance MonadTransControl NoLoggingT where-    type StT NoLoggingT a = a-    liftWith f = NoLoggingT $ f runNoLoggingT-    restoreT = NoLoggingT-    {-# INLINE liftWith #-}-    {-# INLINE restoreT #-}+  type StT NoLoggingT a = a+  liftWith f = NoLoggingT $ f runNoLoggingT+  restoreT = NoLoggingT+  {-# INLINE liftWith #-}+  {-# INLINE restoreT #-}  instance MonadBaseControl b m => MonadBaseControl b (NoLoggingT m) where-     type StM (NoLoggingT m) a = StM m a-     liftBaseWith f = NoLoggingT $-         liftBaseWith $ \runInBase ->-             f $ runInBase . runNoLoggingT-     restoreM = NoLoggingT . restoreM+  type StM (NoLoggingT m) a = StM m a+  liftBaseWith f = NoLoggingT $+    liftBaseWith $ \runInBase ->+      f $ runInBase . runNoLoggingT+  restoreM = NoLoggingT . restoreM +++#if MIN_VERSION_unliftio_core(0, 2, 0) instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where+  withRunInIO inner = NoLoggingT $ withRunInIO $ \run ->+    inner (run . runNoLoggingT)+#else+instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where   askUnliftIO = NoLoggingT $-                withUnliftIO $ \u ->-                pure (UnliftIO (unliftIO u . runNoLoggingT))+    withUnliftIO $ \u ->+      pure (UnliftIO (unliftIO u . runNoLoggingT))+#endif  instance MonadIO m => Katip (NoLoggingT m) where   getLogEnv = liftIO (initLogEnv "NoLoggingT" "no-logging")@@ -488,7 +531,6 @@   localKatipContext = const id   getKatipNamespace = pure mempty   localKatipNamespace = const id-  -- | Convenience function for when you have to integrate with a third -- party API that takes a generic logging function as an argument.

@@ -1,129 +1,218 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE CPP, OverloadedStrings #-}  module Katip.Scribes.Handle where  --------------------------------------------------------------------------------import           Control.Applicative    as A-import           Control.Concurrent-import           Control.Exception      (bracket_, finally)-import           Control.Monad-import           Data.Aeson-import qualified Data.HashMap.Strict    as HM-import           Data.Monoid-import           Data.Scientific        as S-import           Data.Text              (Text)-import           Data.Text.Lazy.Builder-import           Data.Text.Lazy.IO      as T-import           System.IO---------------------------------------------------------------------------------import           Katip.Core-import           Katip.Format.Time      (formatAsLogTime)+import Control.Concurrent+import Control.Exception (bracket_, finally)+import Data.Aeson+#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 (..))+#else+import qualified Data.HashMap.Strict as HM+#endif+import Data.Monoid as M+import Data.Scientific as S+import Data.Text (Text)+import qualified Data.Text as T+import Data.Text.Lazy (toStrict)+import Data.Text.Lazy.Builder+import Data.Text.Lazy.Encoding (decodeUtf8)+import Data.Text.Lazy.IO as T+import qualified Data.Vector as V -------------------------------------------------------------------------------+import Katip.Core+import Katip.Format.Time (formatAsLogTime)+import System.IO +-------------------------------------------------------------------------------  ------------------------------------------------------------------------------- brackets :: Builder -> Builder-brackets m = fromText "[" <> m <> fromText "]"-+brackets m = "[" M.<> m <> "]"+{-# INLINE brackets #-}  ------------------------------------------------------------------------------- getKeys :: LogItem s => Verbosity -> s -> [Builder]-getKeys verb a = concat (renderPair A.<$> HM.toList (payloadObject verb a))+getKeys verb a = concat (toBuilders (payloadObject verb a))+{-# INLINE getKeys #-}++#if MIN_VERSION_aeson(2, 0, 0)+toBuilders :: KM.KeyMap Value -> [[Builder]]+toBuilders = fmap (renderPair . first K.toText) . KM.toList+{-# INLINE toBuilders #-}++toTxtKeyList :: KM.KeyMap v -> [(Text, v)]+toTxtKeyList mp = first K.toText <$> KM.toList mp+{-# INLINE toTxtKeyList #-}+#else+toBuilders :: HM.HashMap Text Value -> [[Builder]]+toBuilders = fmap renderPair . HM.toList+{-# INLINE toBuilders #-}++toTxtKeyList :: HM.HashMap Text v -> [(Text, v)]+toTxtKeyList = HM.toList+{-# INLINE toTxtKeyList #-}+#endif++renderPair :: (Text, Value) -> [Builder]+renderPair (k, v) =+  case v of+    Object o -> concat [renderPair (k <> "." <> k', v') | (k', v') <- toTxtKeyList o]+    Array a -> concat [renderPair (k <> "." <> T.pack (show k'), v') | (k', v') <- V.toList (V.indexed a)]+    String t -> [fromText (k <> ":" <> t)]+    Number n -> [fromText (k <> ":") <> fromString (formatNumber n)]+    Bool b -> [fromText (k <> ":") <> fromString (show b)]+    Null -> [fromText (k <> ":null")]   where-    renderPair :: (Text, Value) -> [Builder]-    renderPair (k,v) =-      case v of-        Object o -> concat [renderPair (k <> "." <> k', v')  | (k', v') <- HM.toList o]-        String t -> [fromText (k <> ":" <> t)]-        Number n -> [fromText (k <> ":") <> fromString (formatNumber n)]-        Bool b -> [fromText (k <> ":") <> fromString (show b)]-        Null -> [fromText (k <> ":null")]-        _ -> mempty -- Can't think of a sensible way to handle arrays     formatNumber :: Scientific -> String     formatNumber n =       formatScientific Generic (if isFloating n then Nothing else Just 0) n-+{-# INLINE renderPair #-}  ------------------------------------------------------------------------------- data ColorStrategy-    = ColorLog Bool-    -- ^ Whether to use color control chars in log output-    | ColorIfTerminal-    -- ^ Color if output is a terminal+  = -- | Whether to use color control chars in log output+    ColorLog Bool+  | -- | Color if output is a terminal+    ColorIfTerminal   deriving (Show, Eq)  -------------------------------------------------------------------------------+ -- | Logs to a file handle such as stdout, stderr, or a file. Contexts -- and other information will be flattened out into bracketed -- fields. For example: ----- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started--- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context--- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started+-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal -- -- Returns the newly-created `Scribe`. The finalizer flushes the -- handle. Handle mode is set to 'LineBuffering' automatically.-mkHandleScribe :: ColorStrategy -> Handle -> Severity -> Verbosity -> IO Scribe-mkHandleScribe cs h sev verb = do-    hSetBuffering h LineBuffering-    colorize <- case cs of-      ColorIfTerminal -> hIsTerminalDevice h-      ColorLog b      -> return b-    lock <- newMVar ()-    let logger i@Item{..} = do-          when (permitItem sev i) $ bracket_ (takeMVar lock) (putMVar lock ()) $-            T.hPutStrLn h $ toLazyText $ formatItem colorize verb i-    return $ Scribe logger (hFlush h)+mkHandleScribe :: ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe+mkHandleScribe = mkHandleScribeWithFormatter bracketFormat+{-# INLINE mkHandleScribe #-} +-- | Logs to a file handle such as stdout, stderr, or a file. Takes a custom+-- `ItemFormatter` that can be used to format `Item` as needed.+--+-- Returns the newly-created `Scribe`. The finalizer flushes the+-- handle. Handle mode is set to 'LineBuffering' automatically.+mkHandleScribeWithFormatter ::+  (forall a. LogItem a => ItemFormatter a) ->+  ColorStrategy ->+  Handle ->+  PermitFunc ->+  Verbosity ->+  IO Scribe+mkHandleScribeWithFormatter itemFormatter cs h permitF verb = do+  hSetBuffering h LineBuffering+  colorize <- case cs of+    ColorIfTerminal -> hIsTerminalDevice h+    ColorLog b -> return b+  lock <- newMVar ()+  let logger i@Item {} = do+        bracket_ (takeMVar lock) (putMVar lock ()) $+          T.hPutStrLn h $ toLazyText $ itemFormatter colorize verb i+  return $ Scribe logger (hFlush h) permitF+{-# INLINE mkHandleScribeWithFormatter #-}  -------------------------------------------------------------------------------+ -- | A specialization of 'mkHandleScribe' that takes a 'FilePath' -- instead of a 'Handle'. It is responsible for opening the file in -- 'AppendMode' and will close the file handle on -- 'closeScribe'/'closeScribes'. Does not do log coloring. Sets handle -- to 'LineBuffering' mode.-mkFileScribe :: FilePath -> Severity -> Verbosity -> IO Scribe-mkFileScribe f sev verb = do+mkFileScribe :: FilePath -> PermitFunc -> Verbosity -> IO Scribe+mkFileScribe f permitF verb = do   h <- openFile f AppendMode-  Scribe logger finalizer <- mkHandleScribe (ColorLog False) h sev verb-  return (Scribe logger (finalizer `finally` hClose h))-+  Scribe logger finalizer permit <- mkHandleScribe (ColorLog False) h permitF verb+  return (Scribe logger (finalizer `finally` hClose h) permit)+{-# INLINE mkFileScribe #-}  --------------------------------------------------------------------------------formatItem :: LogItem a => Bool -> Verbosity -> Item a -> Builder-formatItem withColor verb Item{..} =-    brackets nowStr <>-    brackets (mconcat $ map fromText $ intercalateNs _itemNamespace) <>-    brackets (fromText (renderSeverity' _itemSeverity)) <>-    brackets (fromString _itemHost) <>-    brackets (fromString (show _itemProcess)) <>-    brackets (fromText (getThreadIdText _itemThread)) <>-    mconcat ks <>-    maybe mempty (brackets . fromString . locationToString) _itemLoc <>-    fromText " " <> (unLogStr _itemMessage)++-- | A custom ItemFormatter for logging `Item`s. Takes a `Bool` indicating+-- whether to colorize the output, `Verbosity` of output, and an `Item` to+-- format.+--+-- See `bracketFormat` and `jsonFormat` for examples.+type ItemFormatter a = Bool -> Verbosity -> Item a -> Builder++formatItem :: LogItem a => ItemFormatter a+formatItem = bracketFormat+{-# DEPRECATED formatItem "Use bracketFormat instead" #-}+{-# INLINE formatItem #-}++-- | A traditional 'bracketed' log format. Contexts and other information will+-- be flattened out into bracketed fields. For example:+--+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:32:7] Started+-- > [2016-05-11 21:01:15][MyApp.confrabulation][Debug][myhost.example.com][PID 1724][ThreadId 1154][confrab_factor:42.0][main:Helpers.Logging Helpers/Logging.hs:41:9] Confrabulating widgets, with extra namespace and context+-- > [2016-05-11 21:01:15][MyApp][Info][myhost.example.com][PID 1724][ThreadId 1154][main:Helpers.Logging Helpers/Logging.hs:43:7] Namespace and context are back to normal+bracketFormat :: LogItem a => ItemFormatter a+bracketFormat withColor verb Item {..} =+  brackets nowStr+    <> brackets (mconcat $ map fromText $ intercalateNs _itemNamespace)+    <> brackets (fromText (renderSeverity' _itemSeverity))+    <> brackets (fromString _itemHost)+    <> brackets ("PID " <> fromString (show _itemProcess))+    <> brackets ("ThreadId " <> fromText (getThreadIdText _itemThread))+    <> mconcat ks+    <> maybe mempty (brackets . fromString . locationToString) _itemLoc+    <> fromText " "+    <> (unLogStr _itemMessage)   where     nowStr = fromText (formatAsLogTime _itemTime)     ks = map brackets $ getKeys verb _itemPayload-    renderSeverity' s = case s of-      EmergencyS -> red $ renderSeverity s-      AlertS     -> red $ renderSeverity s-      CriticalS  -> red $ renderSeverity s-      ErrorS     -> red $ renderSeverity s-      WarningS   -> yellow $ renderSeverity s-      _          -> renderSeverity s+    renderSeverity' severity =+      colorBySeverity withColor severity (renderSeverity severity)+{-# INLINE bracketFormat #-}++-- | Logs items as JSON. This can be useful in circumstances where you already+-- have infrastructure that is expecting JSON to be logged to a standard stream+-- or file. For example:+--+-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Started","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":44},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}+-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp","confrabulation"],"data":{"confrab_factor":42},"app":["MyApp"],"msg":"Confrabulating widgets, with extra namespace and context","pid":"10456","loc":{"loc_col":11,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":53},"host":"myhost.example.com","sev":"Debug","thread":"ThreadId 139"}+-- > {"at":"2018-10-02T21:50:30.4523848Z","env":"production","ns":["MyApp"],"data":{},"app":["MyApp"],"msg":"Namespace and context are back to normal","pid":"10456","loc":{"loc_col":9,"loc_pkg":"main","loc_mod":"Helpers.Logging","loc_fn":"Helpers\\Logging.hs","loc_ln":55},"host":"myhost.example.com","sev":"Info","thread":"ThreadId 139"}+jsonFormat :: LogItem a => ItemFormatter a+jsonFormat withColor verb i =+  fromText $+    colorBySeverity withColor (_itemSeverity i) $+      toStrict $ decodeUtf8 $ encode $ itemJson verb i+{-# INLINE jsonFormat #-}++-- | Color a text message based on `Severity`. `ErrorS` and more severe errors+-- are colored red, `WarningS` is colored yellow, and all other messages are+-- rendered in the default color.+colorBySeverity :: Bool -> Severity -> Text -> Text+colorBySeverity withColor severity msg = case severity of+  EmergencyS -> red msg+  AlertS -> red msg+  CriticalS -> red msg+  ErrorS -> red msg+  WarningS -> yellow msg+  _ -> msg+  where     red = colorize "31"     yellow = colorize "33"     colorize c s-      | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"+      | withColor = "\ESC[" <> c <> "m" <> s <> "\ESC[0m"       | otherwise = s-+{-# INLINE colorBySeverity #-}  -- | Provides a simple log environment with 1 scribe going to -- stdout. This is a decent example of how to build a LogEnv and is -- best for scripts that just need a quick, reasonable set up to log -- to stdout.-ioLogEnv :: Severity -> Verbosity -> IO LogEnv-ioLogEnv sev verb = do+ioLogEnv :: PermitFunc -> Verbosity -> IO LogEnv+ioLogEnv permit verb = do   le <- initLogEnv "io" "io"-  lh <- mkHandleScribe ColorIfTerminal stdout sev verb+  lh <- mkHandleScribe ColorIfTerminal stdout permit verb   registerScribe "stdout" lh defaultScribeSettings le+{-# INLINE ioLogEnv #-}

@@ -1,152 +1,203 @@-{-# LANGUAGE CPP                        #-}-{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings          #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Katip.Tests-    ( tests-    ) where +module Katip.Tests+  ( tests,+  )+where  --------------------------------------------------------------------------------import           Control.Applicative       as A-import           Control.Concurrent.STM-import           Control.Exception.Safe-import           Data.Aeson-import qualified Data.HashMap.Strict       as HM-import qualified Data.Map.Strict           as M-import           Data.Monoid-import           Data.Text                 (Text)-import qualified Data.Text.Lazy.Builder    as B-import           Data.Time-import           Data.Time.Clock.POSIX-import           Language.Haskell.TH-import           Lens.Micro                (ASetter, (&), (.~))-import           System.Posix.Types-import           Test.QuickCheck.Instances ()-import           Test.Tasty-import           Test.Tasty.HUnit-import           Test.Tasty.QuickCheck---------------------------------------------------------------------------------import           Katip-import           Katip.Core+import Control.Applicative as A+import Control.Concurrent.STM+import Control.Exception.Safe+import Data.Aeson+#if MIN_VERSION_aeson(2, 0, 0)+import qualified Data.Aeson.Key                    as K+import qualified Data.Aeson.KeyMap                 as KM+#else+import qualified Data.HashMap.Strict as HM+#endif+import qualified Data.Map.Strict as M+import Data.Monoid as Monoid+import Data.Text (Text)+import qualified Data.Text.Lazy.Builder as B+import Data.Time+import Data.Time.Clock.POSIX -------------------------------------------------------------------------------+import Katip+import Katip.Core+import Language.Haskell.TH+import Lens.Micro (ASetter, (&), (.~))+import System.Posix.Types+import Test.QuickCheck.Instances ()+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck +-------------------------------------------------------------------------------  tests :: TestTree-tests = testGroup "Katip"-  [-    testProperty "JSON cycle Item" $ \(i :: Item ()) ->-      prop_json_cycle i-  , eqItemTests-  , testProperty "renderSeverity/textToSeverity cycle" $ \sev ->-      textToSeverity(renderSeverity sev) === Just sev-  , testProperty "processIDToText/textToProcessID cycle" $ \pid ->-      textToProcessID (processIDToText pid) === Just pid-  , testCase "processIDToText is just the number" $ do-      processIDToText 123 @?= "123"-  , logContextsTests-  , closeScribeTests-  , closeScribesTests-  , loggingTests-  ]-+tests =+  testGroup+    "Katip"+    [ testProperty "JSON cycle Item" $ \(i :: Item ()) ->+        prop_json_cycle i,+      testProperty "JSON cycle verbosity" $ \(v :: Verbosity) ->+        prop_json_cycle v,+      eqItemTests,+      testProperty "renderSeverity/textToSeverity cycle" $ \sev ->+        textToSeverity (renderSeverity sev) === Just sev,+      testProperty "processIDToText/textToProcessID cycle" $ \pid ->+        textToProcessID (processIDToText pid) === Just pid,+      testCase "processIDToText is just the number" $ do+        processIDToText 123 @?= "123",+      logContextsTests,+      closeScribeTests,+      closeScribesTests,+      loggingTests+    ]  ------------------------------------------------------------------------------- logContextsTests :: TestTree-logContextsTests = testGroup "logContexts"-  [-    testCase "overwrites with the right-hand side (right-bias)" $ do-      let l1 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])-          l2 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("b" :: Text))])-          l3 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("c" :: Text))])-          both = l1 <> l2 <> l3-      toObject both @?= HM.singleton "foo" (String "c")-  , testCase "respects payloadKeys for each constituent payload" $ do-      let everything = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])-          conservative = liftPayload (ConservativePayload "always" "rarely")-          both = everything <> conservative-      payloadKeys V2 both @?= SomeKeys ["often_shown", "rarely_shown", "foo"]-      payloadKeys V1 both @?= SomeKeys ["often_shown", "foo"]-  ]+logContextsTests =+  testGroup+    "logContexts"+    [ testCase "overwrites with the right-hand side (right-bias)" $ do+        let l1 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])+            l2 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("b" :: Text))])+            l3 = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("c" :: Text))])+            both = l1 <> l2 <> l3+        toObject both @?= singletonMap "foo" (String "c"),+      testCase "respects payloadKeys for each constituent payload" $ do+        let everything = liftPayload (SimpleLogPayload [("foo", AnyLogPayload ("a" :: Text))])+            conservative = liftPayload (ConservativePayload "always" "rarely")+            both = everything <> conservative+        assertEquivalentPayloadSelection+          (payloadKeys V2 both)+          (SomeKeys somePayloadKeys)+        assertEquivalentPayloadSelection+          (payloadKeys V1 both)+          (SomeKeys ["often_shown", "foo"])+    ] +assertEquivalentPayloadSelection :: PayloadSelection -> PayloadSelection -> Assertion+assertEquivalentPayloadSelection a b+  | equivalentPayloadSelection a b = pure ()+  | otherwise = assertFailure ("Expected " <> show a <> " =~ " <> show b) +#if MIN_VERSION_aeson(2, 0, 0)+singletonMap :: K.Key -> v -> KM.KeyMap v+singletonMap = KM.singleton+#else+singletonMap :: Text -> v -> HM.HashMap Text v+singletonMap = HM.singleton+#endif++#if MIN_VERSION_unordered_containers(0, 2, 16)+somePayloadKeys :: [Text]+somePayloadKeys = ["rarely_shown", "often_shown", "foo"]+#else+somePayloadKeys :: [Text]+somePayloadKeys = ["often_shown", "rarely_shown", "foo"]+#endif+ ------------------------------------------------------------------------------- closeScribeTests :: TestTree-closeScribeTests = testGroup "closeScribe"-  [ testCase "removes the specified scribe" $ do-      (scr, finalizerCalled) <- trivialScribe-      le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"-      le' <- closeScribe "trivial" le-      closed <- atomically (readTVar finalizerCalled)-      assertBool "finalizer called" closed-      assertBool "should not have trivial key in scribes" (not (M.member "trivial" (_logEnvScribes le')))-  , testCase "does nothing for a missing scribe" $ do-      le <- initLogEnv "ns" "test"-      le' <- closeScribe "nah" le-      assertBool "does not affect scribes" (M.null (_logEnvScribes le'))-  , testCase "re-throws finalizer exceptions" $ do-      (scr, finalizerCalled) <- brokenScribe 1-      le <- registerScribe "broken" scr defaultScribeSettings =<< initLogEnv "ns" "test"-      res <- try (closeScribe "broken" le)-      closed <- atomically (readTVar finalizerCalled)-      assertBool "finalizer called" closed-      case res of-        Left (ScribeBroken scribeNo) -> scribeNo @?= 1-        Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"-  ]-+closeScribeTests =+  testGroup+    "closeScribe"+    [ testCase "removes the specified scribe" $ do+        (scr, finalizerCalled) <- trivialScribe+        le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"+        le' <- closeScribe "trivial" le+        closed <- atomically (readTVar finalizerCalled)+        assertBool "finalizer called" closed+        assertBool "should not have trivial key in scribes" (not (M.member "trivial" (_logEnvScribes le'))),+      testCase "does nothing for a missing scribe" $ do+        le <- initLogEnv "ns" "test"+        le' <- closeScribe "nah" le+        assertBool "does not affect scribes" (M.null (_logEnvScribes le')),+      testCase "re-throws finalizer exceptions" $ do+        (scr, finalizerCalled) <- brokenScribe 1+        le <- registerScribe "broken" scr defaultScribeSettings =<< initLogEnv "ns" "test"+        res <- try (closeScribe "broken" le)+        closed <- atomically (readTVar finalizerCalled)+        assertBool "finalizer called" closed+        case res of+          Left (ScribeBroken scribeNo) -> scribeNo @?= 1+          Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"+    ]  --------------------------------------------------------------------------------loggingTests :: TestTree-loggingTests = testGroup "logging"-  [ testCase "logs in order with contexts, namespaces, etc" $ do-      (le, items) <- recordingEnv-      runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ do-        $(logTM) InfoS "basic log"-        katipNoLogging $ do-          $(logTM) InfoS "you cant see this"-        katipAddNamespace "added" $ do-          katipAddNamespace "namespace" $ do-            $(logTM) InfoS "with namespaces"-          katipAddContext (sl "additional" True) $ do-            $(logTM) InfoS "additional context"-      _ <- closeScribes le-      summary <- fmap summarizeItem <$> readTVarIO items-      let baseCtx = HM.singleton "base_context" (Number 42)-      let baseNS = "tests" <> "base_namespace"-      summary @?=-        [ (baseNS, baseCtx, "basic log")-        , (baseNS <> "added" <> "namespace", baseCtx, "with namespaces")-        , (baseNS <> "added", HM.insert "additional" (Bool True) baseCtx, "additional context")-        ]-  ]+loggingTests :: HasCallStack => TestTree+loggingTests =+  testGroup+    "logging"+    [ testCase "logs in order with contexts, namespaces, etc" $ do+        (le, items) <- recordingEnv+        runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ do+          $(logTM) InfoS "basic log"+          katipNoLogging $ do+            $(logTM) InfoS "you cant see this"+          katipAddNamespace "added" $ do+            katipAddNamespace "namespace" $ do+              $(logTM) InfoS "with namespaces"+            katipAddContext (sl "additional" True) $ do+              $(logTM) InfoS "additional context"+        _ <- closeScribes le+        summary <- fmap summarizeItem <$> readTVarIO items+        let baseCtx = singletonMap "base_context" (Number 42)+        let baseNS = "tests" <> "base_namespace"+        summary+          @?= [ (baseNS, baseCtx, "basic log"),+                (baseNS <> "added" <> "namespace", baseCtx, "with namespaces"),+                (baseNS <> "added", insertMap "additional" (Bool True) baseCtx, "additional context")+              ],+      testCase "Katip.Monadic.logLocM" $ do+        (le, items) <- recordingEnv+        runKatipContextT le (sl "base_context" (42 :: Int)) "base_namespace" $ logLocM InfoS "basic log"+        _ <- closeScribes le+        loggedItems <- readTVarIO items+        let loc = _itemLoc (head loggedItems)+        fmap loc_module loc @?= Just "Katip.Tests"+    ]   where     recordingEnv :: IO (LogEnv, TVar [Item Object])     recordingEnv = do-      items <- newTVarIO mempty-      let scribe = Scribe-            { liPush = \i -> atomically (modifyTVar' items (<> [toObject <$> i]))-            , scribeFinalizer = return ()-            }+      items <- newTVarIO Monoid.mempty+      let scribe =+            Scribe+              { liPush = \i -> atomically (modifyTVar' items (<> [toObject <$> i])),+                scribeFinalizer = return (),+                scribePermitItem = permitItem DebugS+              }       le1 <- initLogEnv "tests" "test"       le2 <- registerScribe "recorder" scribe defaultScribeSettings le1       return (le2, items)     summarizeItem :: Item Object -> (Namespace, Object, LogStr)     summarizeItem Item {..} = (_itemNamespace, _itemPayload, _itemMessage) +#if MIN_VERSION_aeson(2, 0, 0)+insertMap :: K.Key -> v -> KM.KeyMap v -> KM.KeyMap v+insertMap = KM.insert+#else+insertMap :: Text -> v -> HM.HashMap Text v -> HM.HashMap Text v+insertMap = HM.insert+#endif  ------------------------------------------------------------------------------- trivialScribe :: IO (Scribe, TVar Bool) trivialScribe = do   finalizerCalled <- newTVarIO False   let finalizer = atomically (writeTVar finalizerCalled True)-  return (Scribe (const (return ())) finalizer, finalizerCalled)-+  return (Scribe (const (return ())) finalizer (permitItem DebugS), finalizerCalled)  ------------------------------------------------------------------------------- brokenScribe :: Int -> IO (Scribe, TVar Bool)@@ -155,68 +206,67 @@   let finalizer = do         atomically (writeTVar finalizerCalled True)         throw (ScribeBroken scribeNum)-  return (Scribe (const (return ())) finalizer, finalizerCalled)-+  return (Scribe (const (return ())) finalizer (permitItem DebugS), finalizerCalled)  ------------------------------------------------------------------------------- data BrokenScribeError = ScribeBroken Int deriving (Show, Typeable) - instance Exception BrokenScribeError  ------------------------------------------------------------------------------- closeScribesTests :: TestTree-closeScribesTests = testGroup "closeScribes"-  [ testCase "returns a log env with no scribes" $ do-      (scr, finalizerCalled) <- trivialScribe-      le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"-      le' <- closeScribes le-      closed <- atomically (readTVar finalizerCalled)-      assertBool "finalizer called" closed-      assertBool "remvoes all scribes" (M.null (_logEnvScribes le'))-  , testCase "throws the first exception encountered after closing all scribes" $ do-     (scr1, finalizerCalled1) <- brokenScribe 1-     (scr2, finalizerCalled2) <- brokenScribe 2-     le <- registerScribe "broken2" scr2 defaultScribeSettings =<< registerScribe "broken1" scr1 defaultScribeSettings =<< initLogEnv "ns" "test"-     res <- try (closeScribes le)-     closed1 <- atomically (readTVar finalizerCalled1)-     assertBool "finalizer 1 called" closed1-     closed2 <- atomically (readTVar finalizerCalled2)-     assertBool "finalizer 2 called" closed2-     case res of-       Left (ScribeBroken scribeNo) -> scribeNo @?= 1-       Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"-  ]-+closeScribesTests =+  testGroup+    "closeScribes"+    [ testCase "returns a log env with no scribes" $ do+        (scr, finalizerCalled) <- trivialScribe+        le <- registerScribe "trivial" scr defaultScribeSettings =<< initLogEnv "ns" "test"+        le' <- closeScribes le+        closed <- atomically (readTVar finalizerCalled)+        assertBool "finalizer called" closed+        assertBool "remvoes all scribes" (M.null (_logEnvScribes le')),+      testCase "throws the first exception encountered after closing all scribes" $ do+        (scr1, finalizerCalled1) <- brokenScribe 1+        (scr2, finalizerCalled2) <- brokenScribe 2+        le <- registerScribe "broken2" scr2 defaultScribeSettings =<< registerScribe "broken1" scr1 defaultScribeSettings =<< initLogEnv "ns" "test"+        res <- try (closeScribes le)+        closed1 <- atomically (readTVar finalizerCalled1)+        assertBool "finalizer 1 called" closed1+        closed2 <- atomically (readTVar finalizerCalled2)+        assertBool "finalizer 2 called" closed2+        case res of+          Left (ScribeBroken scribeNo) -> scribeNo @?= 1+          Right _ -> assertFailure "Expected to throw a ScribeBroken but it did not"+    ]  --------------------------------------------------------------------------------data ConservativePayload = ConservativePayload {-      oftenShown  :: Text-    , rarelyShown :: Text-    }-+data ConservativePayload = ConservativePayload+  { oftenShown :: Text,+    rarelyShown :: Text+  }  instance ToJSON ConservativePayload where-  toJSON ConservativePayload {..} = object ["often_shown" .= oftenShown-                                           ,"rarely_shown" .= rarelyShown]-+  toJSON ConservativePayload {..} =+    object+      [ "often_shown" .= oftenShown,+        "rarely_shown" .= rarelyShown+      ]  instance ToObject ConservativePayload - instance LogItem ConservativePayload where   payloadKeys V1 _ = SomeKeys ["often_shown"]   payloadKeys V0 _ = SomeKeys []-  payloadKeys _ _  = AllKeys+  payloadKeys _ _ = AllKeys  ------------------------------------------------------------------------------- prop_json_cycle :: (ToJSON a, FromJSON a, Eq a, Show a) => a -> Property prop_json_cycle a = eitherDecode (encode a) === Right a - ------------------------------------------------------------------------------- instance Arbitrary a => Arbitrary (Item a) where-    arbitrary = Item+  arbitrary =+    Item       A.<$> arbitrary       <*> arbitrary       <*> arbitrary@@ -229,52 +279,57 @@       <*> arbitrary       <*> arbitrary - --------------------------------------------------------------------------------newtype CleanUTCTime = CleanUTCTime {-      getCleanUTCTime :: UTCTime-    }-+newtype CleanUTCTime = CleanUTCTime+  { getCleanUTCTime :: UTCTime+  }  ------------------------------------------------------------------------------- -- Work around time parsing precision issues in aeson instance Arbitrary CleanUTCTime where-    arbitrary = CleanUTCTime . posixSecondsToUTCTime . fromInteger <$> arbitrary-+  arbitrary = CleanUTCTime . posixSecondsToUTCTime . fromInteger <$> arbitrary  ------------------------------------------------------------------------------- deriving instance Arbitrary Namespace+ deriving instance Arbitrary Environment+ deriving instance Arbitrary ThreadIdText-deriving instance Arbitrary CPid +deriving instance Arbitrary CPid  ------------------------------------------------------------------------------- instance Arbitrary Loc where-    arbitrary = do-      f <- arbitrary-      p <- arbitrary-      m <- arbitrary-      s <- arbitrary-      return $ Loc f p m s s+  arbitrary = do+    f <- arbitrary+    p <- arbitrary+    m <- arbitrary+    s <- arbitrary+    return $ Loc f p m s s +-------------------------------------------------------------------------------+instance Arbitrary Verbosity where+  arbitrary = oneof $ map pure [V0, V1, V2, V3]  ------------------------------------------------------------------------------- instance Arbitrary Severity where-    arbitrary = oneof $ map pure [ DebugS-                                 , InfoS-                                 , NoticeS-                                 , WarningS-                                 , ErrorS-                                 , CriticalS-                                 , AlertS-                                 , EmergencyS-                                 ]-+  arbitrary =+    oneof $+      map+        pure+        [ DebugS,+          InfoS,+          NoticeS,+          WarningS,+          ErrorS,+          CriticalS,+          AlertS,+          EmergencyS+        ]  ------------------------------------------------------------------------------- instance Arbitrary LogStr where-    arbitrary = LogStr . B.fromText <$> arbitrary+  arbitrary = LogStr . B.fromText <$> arbitrary  ------------------------------------------------------------------------------- -- Somewhat test whether all fields are taken into account in `==`@@ -286,20 +341,22 @@ #endif  eqItemTests :: TestTree-eqItemTests = testGroup "Eq Item"-  [ testProperty "itemApp" $ prop_field itemApp-  , testProperty "itemEnv" $ prop_field itemEnv-  , testProperty "itemSeverity" $ prop_field itemSeverity-  , testProperty "itemThread" $ prop_field itemThread-  , testProperty "itemHost" $ prop_field itemHost-  , testProperty "itemProcess" $ prop_field itemProcess-  , testProperty "itemPayload" $ prop_field itemPayload-  , testProperty "itemMessage" $ prop_field itemMessage-  , testProperty "itemTime" $ prop_field itemTime-  , testProperty "itemNamespace" $ prop_field itemNamespace-  , testProperty "itemLoc" $ prop_field itemLoc-  ]+eqItemTests =+  testGroup+    "Eq Item"+    [ testProperty "itemApp" $ prop_field itemApp,+      testProperty "itemEnv" $ prop_field itemEnv,+      testProperty "itemSeverity" $ prop_field itemSeverity,+      testProperty "itemThread" $ prop_field itemThread,+      testProperty "itemHost" $ prop_field itemHost,+      testProperty "itemProcess" $ prop_field itemProcess,+      testProperty "itemPayload" $ prop_field itemPayload,+      testProperty "itemMessage" $ prop_field itemMessage,+      testProperty "itemTime" $ prop_field itemTime,+      testProperty "itemNamespace" $ prop_field itemNamespace,+      testProperty "itemLoc" $ prop_field itemLoc+    ]   where     prop_field :: Eq a => ASetter (Item ()) (Item ()) a a -> Item () -> a -> a -> Bool     prop_field field item f1 f2 =-        ((item & field .~ f1) == (item & field .~ f2)) == (f1 == f2)+      ((item & field .~ f1) == (item & field .~ f2)) == (f1 == f2)

@@ -1,55 +1,51 @@ module Katip.Tests.Format.Time-    ( tests-    ) where+  ( tests,+  )+where  --------------------------------------------------------------------------------import           Data.Aeson              (toJSON)-import qualified Data.Text               as Text-import           Data.Time-import           Data.Time.Clock.POSIX+import Data.Aeson (toJSON)+import qualified Data.Text as Text+import Data.Time+import Data.Time.Clock.POSIX import qualified Data.Time.Locale.Compat as LC-import           Test.Tasty-import           Test.Tasty.HUnit-import           Test.Tasty.QuickCheck --------------------------------------------------------------------------------import           Katip.Format.Time--------------------------------------------------------------------------------+import Katip.Format.Time+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck +-------------------------------------------------------------------------------  tests :: TestTree-tests = testGroup "Katip.Format.Time"-  [ testCase "formatAsLogTime" $ do-      assertEqual "time 1" (formatDT t1) (formatAsLogTime t1)-      assertEqual "time 2" (formatDT t2) (formatAsLogTime t2)-      assertEqual "time 3" (formatDT t3) (formatAsLogTime t3)-      assertEqual "time 4" (formatDT t4) (formatAsLogTime t4)-      assertEqual "time 5" (formatDT t5) (formatAsLogTime t5)--  , testCase "formatAsIso8601" $ do-      assertEqual "time 1" (formatDTISO t1) (formatAsIso8601 t1)-      assertEqual "time 2" (formatDTISO t2) (formatAsIso8601 t2)-      assertEqual "time 3" (formatDTISO t3) (formatAsIso8601 t3)-      assertEqual "time 4" (formatDTISO t4) (formatAsIso8601 t4)-      assertEqual "time 5" (formatDTISO t5) (formatAsIso8601 t5)--  , testCase "formatAsIso8601 Aeson" $ do-      assertEqual "time 1" (toJSON t1) (toJSON $ formatAsIso8601 t1)-      assertEqual "time 2" (toJSON t2) (toJSON $ formatAsIso8601 t2)-      assertEqual "time 3" (toJSON t3) (toJSON $ formatAsIso8601 t3)-      assertEqual "time 4" (toJSON t4) (toJSON $ formatAsIso8601 t4)-      assertEqual "time 5" (toJSON t5) (toJSON $ formatAsIso8601 t5)---  , testProperty "LogTime same as Date.Time" $ \(ArbUTCTime t) ->-      prop_format_log t--  , testProperty "ISO 8601 same as Date.Time" $ \(ArbUTCTime t) ->-      prop_format_iso t--  , testProperty "ISO 8601 same as Aeson" $ \(ArbUTCTime t) ->-      prop_format_aeson t--  ]+tests =+  testGroup+    "Katip.Format.Time"+    [ testCase "formatAsLogTime" $ do+        assertEqual "time 1" (formatDT t1) (formatAsLogTime t1)+        assertEqual "time 2" (formatDT t2) (formatAsLogTime t2)+        assertEqual "time 3" (formatDT t3) (formatAsLogTime t3)+        assertEqual "time 4" (formatDT t4) (formatAsLogTime t4)+        assertEqual "time 5" (formatDT t5) (formatAsLogTime t5),+      testCase "formatAsIso8601" $ do+        assertEqual "time 1" (formatDTISO t1) (formatAsIso8601 t1)+        assertEqual "time 2" (formatDTISO t2) (formatAsIso8601 t2)+        assertEqual "time 3" (formatDTISO t3) (formatAsIso8601 t3)+        assertEqual "time 4" (formatDTISO t4) (formatAsIso8601 t4)+        assertEqual "time 5" (formatDTISO t5) (formatAsIso8601 t5),+      testCase "formatAsIso8601 Aeson" $ do+        assertEqual "time 1" (toJSON t1) (toJSON $ formatAsIso8601 t1)+        assertEqual "time 2" (toJSON t2) (toJSON $ formatAsIso8601 t2)+        assertEqual "time 3" (toJSON t3) (toJSON $ formatAsIso8601 t3)+        assertEqual "time 4" (toJSON t4) (toJSON $ formatAsIso8601 t4)+        assertEqual "time 5" (toJSON t5) (toJSON $ formatAsIso8601 t5),+      testProperty "LogTime same as Date.Time" $ \(ArbUTCTime t) ->+        prop_format_log t,+      testProperty "ISO 8601 same as Date.Time" $ \(ArbUTCTime t) ->+        prop_format_iso t,+      testProperty "ISO 8601 same as Aeson" $ \(ArbUTCTime t) ->+        prop_format_aeson t+    ]   where     t1 = UTCTime (fromGregorian 2016 12 34) 5025.123456789012     t2 = UTCTime (fromGregorian 2016 1 23) 5025.123@@ -72,10 +68,11 @@ prop_format_aeson :: UTCTime -> Property prop_format_aeson a = toJSON a === toJSON (formatAsIso8601 a) - newtype ArbUTCTime = ArbUTCTime UTCTime-                   deriving (Show)+  deriving (Show)  instance Arbitrary ArbUTCTime where-    arbitrary = fmap (ArbUTCTime . posixSecondsToUTCTime . fromInteger)-                     arbitrary+  arbitrary =+    fmap+      (ArbUTCTime . posixSecondsToUTCTime . fromInteger)+      arbitrary

@@ -1,40 +1,40 @@-[2016-06-12 12:34:56][foo][Debug][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Notice][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Warning][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Error][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Critical][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Alert][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Emergency][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][0][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][1][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][2147483647][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][www.example.com][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][127.0.0.1][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][0][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][1][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][1337][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][2147483647][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Debug][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Notice][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Warning][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Error][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Critical][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Alert][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Emergency][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 0][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 2147483647][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][www.example.com][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][127.0.0.1][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 0][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 1][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 1337][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 2147483647][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message with newline-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note]  a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] сообщение-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] 哈囉世界-[2000-01-01 00:00:00][foo][Info][example][7331][1337][note.deep:some note] message-[2123-12-31 23:59:59][foo][Info][example][7331][1337][note.deep:some note] message-[2016-10-10 01:01:05][foo][Info][example][7331][1337][note.deep:some note] message-[2100-12-31 12:59:10][foo][Info][example][7331][1337][note.deep:some note] message-[1982-01-01 12:30:00][foo][Info][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo.bar][Info][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][фу.бар][Info][example][7331][1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note]  a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message a really long message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] сообщение+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] 哈囉世界+[2000-01-01 00:00:00][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2123-12-31 23:59:59][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-10-10 01:01:05][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2100-12-31 12:59:10][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[1982-01-01 12:30:00][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo.bar][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][фу.бар][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message [2016-06-12 12:34:56][with-newline][Info][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note][main:Some.Module path/Some/Module.hs:30:1] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][note.deep:some note][main:Some.Module путь/Some/Module.hs:3000:9000] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][sub:null][text:][num:0][float:0] message-[2016-06-12 12:34:56][foo][Info][example][7331][1337][sub.note.deep:some note][text:note][num:10][float:5.5] message+newline][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note][main:Some.Module path/Some/Module.hs:30:1] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][note.deep:some note][main:Some.Module путь/Some/Module.hs:3000:9000] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][sub:null][text:][num:0][float:0] message+[2016-06-12 12:34:56][foo][Info][example][PID 7331][ThreadId 1337][sub.note.deep:some note][text:note][num:10][float:5.5] message

@@ -1,229 +1,263 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+ module Katip.Tests.Scribes.Handle-    ( tests-    ) where+  ( tests,+  )+where  --------------------------------------------------------------------------------import           Control.Monad-import           Data.Aeson-import qualified Data.ByteString.Lazy       as BL-import qualified Data.ByteString.Char8      as B-import           Data.Monoid-import           Data.Text                  (Text)-import qualified Data.Text                  as T-import qualified Data.Text.Encoding         as T-import qualified Data.Text.Lazy             as LT-import qualified Data.Text.Lazy.Builder     as LT-import           Data.Time-import           Language.Haskell.TH.Syntax (Loc (..))-import           Lens.Micro                 ((.~))-import           System.Directory-import           System.IO-import           Test.Tasty-import           Test.Tasty.Golden-import           Test.Tasty.HUnit-import           Text.Regex.TDFA---------------------------------------------------------------------------------import           Katip-import           Katip.Scribes.Handle+import Control.Monad+import Data.Aeson+import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as BL+import Data.Monoid as M+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Builder as LT+import Data.Time -------------------------------------------------------------------------------+import Katip+import Language.Haskell.TH.Syntax (Loc (..))+import Lens.Micro ((.~))+import System.Directory+import System.IO+import Test.Tasty+import Test.Tasty.Golden+import Test.Tasty.HUnit+import Text.Regex.TDFA +-------------------------------------------------------------------------------  tests :: TestTree-tests = testGroup "Katip.Scribes.Handle"-  [-    withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do-       (path, h, fin, le) <- setupScribe-       runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"-       fin-       runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"-       hClose h-       res <- readFile path-       let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String-       let matches = res =~ pat-       assertBool (show res <> " did not match") matches-  , withResource setupFile (const (return ())) $ \setupScribe -> testCase "logs correct data to a file" $ do-      (path, fin, le) <- setupScribe-      runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"-      fin-      runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"-      res <- readFile path-      let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[[:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String-      let matches = res =~ pat-      assertBool (show res <> " did not match") matches-  , withResource setupTempFile teardownTempFile $ \setupFn ->-      goldenVsString "Text-golden"-                     "test/Katip/Tests/Scribes/Handle-text.golden"-                     (setupFn >>= writeTextLog)-  ]+tests =+  testGroup+    "Katip.Scribes.Handle"+    [ withResource setup teardown $ \setupScribe -> testCase "logs the correct data" $ do+        (path, h, fin, le) <- setupScribe+        runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"+        fin+        runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"+        hClose h+        res <- readFile path+        let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String+        let matches = res =~ pat+        assertBool (show res M.<> " did not match") matches,+      withResource setupFile (const (return ())) $ \setupScribe -> testCase "logs correct data to a file" $ do+        (path, fin, le) <- setupScribe+        runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "test message"+        fin+        runKatipT le $ logItem dummyLogItem "test" Nothing InfoS "wont make it in"+        res <- readFile path+        let pat = "\\[[[:digit:]]{4}-[[:digit:]]{2}-[[:digit:]]{2} [[:digit:]]{2}:[[:digit:]]{2}:[[:digit:]]{2}\\]\\[katip-test.test\\]\\[Info\\]\\[.+\\]\\[[PID [:digit:]]+\\]\\[ThreadId [[:digit:]]+\\]\\[note.deep:some note\\] test message" :: String+        let matches = res =~ pat+        assertBool (show res <> " did not match") matches,+      withResource setupTempFile teardownTempFile $ \setupFn ->+        goldenVsString+          "Text-golden"+          goldenTextPath+          (setupFn >>= writeTextLog),+      withResource setupTempFile teardownTempFile $ \setupFn ->+        goldenVsString+          "Json-golden"+          goldenJsonPath+          (setupFn >>= writeJsonLog)+    ] +#if MIN_VERSION_aeson(2, 0, 0)+-- keys get reordered, hence different output+goldenTextPath :: FilePath+goldenTextPath = "test/Katip/Tests/Scribes/Handle-text-aeson2.golden"+goldenJsonPath :: FilePath+goldenJsonPath = "test/Katip/Tests/Scribes/Handle-json-aeson2.golden"+#elif MIN_VERSION_unordered_containers(0, 2, 16)+goldenTextPath :: FilePath+goldenTextPath = "test/Katip/Tests/Scribes/Handle-text-aeson2.golden"+goldenJsonPath :: FilePath+goldenJsonPath = "test/Katip/Tests/Scribes/Handle-json-aeson2.golden"+#else+goldenTextPath :: FilePath+goldenTextPath = "test/Katip/Tests/Scribes/Handle-text.golden"+goldenJsonPath :: FilePath+goldenJsonPath = "test/Katip/Tests/Scribes/Handle-json.golden"+#endif  --------------------------------------------------------------------------------data DummyLogItem = DummyLogItem {-      dliNote :: Text-    }-+data DummyLogItem = DummyLogItem+  { dliNote :: Text+  }  instance ToJSON DummyLogItem where-  toJSON dli = object-    [ "note" .= object [ "deep" .= dliNote dli-                       ]-    ]-+  toJSON dli =+    object+      [ "note"+          .= object+            [ "deep" .= dliNote dli+            ]+      ]  instance ToObject DummyLogItem - instance LogItem DummyLogItem where   payloadKeys _ _ = AllKeys - ------------------------------------------------------------------------------- dummyLogItem :: DummyLogItem dummyLogItem = DummyLogItem "some note" - ------------------------------------------------------------------------------- setup :: IO (FilePath, Handle, IO (), LogEnv) setup = do   tempDir <- getTemporaryDirectory   (fp, h) <- openTempFile tempDir "katip.log"-  s <- mkHandleScribe (ColorLog False) h DebugS V3+  s <- mkHandleScribe (ColorLog False) h (permitItem DebugS) V3   le <- initLogEnv "katip-test" "test"   le' <- registerScribe "handle" s defaultScribeSettings le   return (fp, h, void (closeScribes le'), le') - ------------------------------------------------------------------------------- teardown :: (a, Handle, b, c) -> IO () teardown (_, h, _, _) = do   chk <- hIsOpen h   when chk $ hClose h - ------------------------------------------------------------------------------- setupFile :: IO (FilePath, IO (), LogEnv) setupFile = do   tempDir <- getTemporaryDirectory   (fp, h) <- openTempFile tempDir "katip.log"   hClose h-  s <- mkFileScribe fp DebugS V3+  s <- mkFileScribe fp (permitItem DebugS) V3   le <- initLogEnv "katip-test" "test"   le' <- registerScribe "handle" s defaultScribeSettings le   return (fp, void (closeScribes le'), le') - -- Following code tests Handle scribe output against a golden file. -- This test will fail on non utf8 locales because golden file is in utf-8.--- It generates all meaningfull variations of Item, and also tests+-- It generates all meaningful variations of Item, and also tests -- writing of payload of different Aeson constructors------ Note: currently Handle scribe does not write Array items at all ------------------------------------------------------------------------------- data AllTypesLogItem = AllTypesLogItem-    { atlText  :: Text-    , atlNum   :: Int-    , atlFloat :: Float-    , atlList  :: [Text]-    , atlSub   :: Maybe DummyLogItem-    }-+  { atlText :: Text,+    atlNum :: Int,+    atlFloat :: Float,+    atlList :: [Text],+    atlSub :: Maybe DummyLogItem+  }  instance ToJSON AllTypesLogItem where-  toJSON it = object-    [ "text"     .= atlText it-    , "num"      .= atlNum it-    , "float"    .= atlFloat it-    , "list"     .= atlList it-    , "sub"      .= atlSub it-    ]-+  toJSON it =+    object+      [ "text" .= atlText it,+        "num" .= atlNum it,+        "float" .= atlFloat it,+        "list" .= atlList it,+        "sub" .= atlSub it+      ]  instance ToObject AllTypesLogItem - instance LogItem AllTypesLogItem where   payloadKeys _ _ = AllKeys - ------------------------------------------------------------------------------- theItem :: Item DummyLogItem-theItem = Item (Namespace ["app"])-               (Environment "production")-               (InfoS)-               (ThreadIdText "1337")-               "example"-               7331-               dummyLogItem-               "message"-               (mkUTCTime 2016 6 12 12 34 56)-               (Namespace ["foo"])-               Nothing+theItem =+  Item+    (Namespace ["app"])+    (Environment "production")+    (InfoS)+    (ThreadIdText "1337")+    "example"+    7331+    dummyLogItem+    "message"+    (mkUTCTime 2016 6 12 12 34 56)+    (Namespace ["foo"])+    Nothing  genItems :: [Item DummyLogItem]-genItems = concat $-  [ [ itemSeverity .~ s $ theItem-          | s <- [minBound .. maxBound]-    ]-  , [ itemThread .~ (ThreadIdText . T.pack $ show t) $ theItem-          | t <- [0 :: Int, 1, 1337, 2147483647]-    ]-  , [ itemHost .~ h $ theItem-          | h <- ["example", "www.example.com", "127.0.0.1"]-    ]-  , [ itemProcess .~ p $ theItem-          | p <- [0, 1, 1337, 2147483647]-    ]-  , [ itemMessage .~ LogStr m $ theItem-          | m <- [ "message"-                 , "message\nwith newline"-                 , LT.fromLazyText (LT.replicate 40 " a really long message")-                 , "сообщение"-                 , "哈囉世界"-                 ]-    ]-  , [ itemTime .~ t $ theItem-          | t <- genDates-    ]-  , [ itemNamespace .~ Namespace ns $ theItem-          | ns <- [ ["foo"]-                  , ["foo", "bar"]-                  , ["фу", "бар"]-                  , ["with\nnewline"] ]-    ]-  , [ itemLoc .~ l $ theItem | l <- genLocs+genItems =+  concat $+    [ [ itemSeverity .~ s $ theItem+        | s <- [minBound .. maxBound]+      ],+      [ itemThread .~ (ThreadIdText . T.pack $ show t) $ theItem+        | t <- [0 :: Int, 1, 1337, 2147483647]+      ],+      [ itemHost .~ h $ theItem+        | h <- ["example", "www.example.com", "127.0.0.1"]+      ],+      [ itemProcess .~ p $ theItem+        | p <- [0, 1, 1337, 2147483647]+      ],+      [ itemMessage .~ LogStr m $ theItem+        | m <-+            [ "message",+              "message\nwith newline",+              LT.fromLazyText (LT.replicate 40 " a really long message"),+              "сообщение",+              "哈囉世界"+            ]+      ],+      [ itemTime .~ t $ theItem+        | t <- genDates+      ],+      [ itemNamespace .~ Namespace ns $ theItem+        | ns <-+            [ ["foo"],+              ["foo", "bar"],+              ["фу", "бар"],+              ["with\nnewline"]+            ]+      ],+      [ itemLoc .~ l $ theItem | l <- genLocs+      ]     ]-  ]  genDates :: [UTCTime] genDates =-  [ mkUTCTime 2000 1   1 0   0  0.0-  , mkUTCTime 2123 12 31 23  59 59.999999999999-  , mkUTCTime 2016 10 10 1   1  5.0-  , mkUTCTime 2100 12 31 12  59 10.1-  , mkUTCTime 1982 1  1  12  30 0.000000000001+  [ mkUTCTime 2000 1 1 0 0 0.0,+    mkUTCTime 2123 12 31 23 59 59.999999999999,+    mkUTCTime 2016 10 10 1 1 5.0,+    mkUTCTime 2100 12 31 12 59 10.1,+    mkUTCTime 1982 1 1 12 30 0.000000000001   ]  genLocs :: [Maybe Loc] genLocs =-  [ Nothing-  , Just $ Loc "path/Some/Module.hs"-               "main"-               "Some.Module"-               (30,1) (30,14)-  , Just $ Loc "путь/Some/Module.hs"-               "main"-               "Some.Module"-               (3000,9000) (4000,1)+  [ Nothing,+    Just $+      Loc+        "path/Some/Module.hs"+        "main"+        "Some.Module"+        (30, 1)+        (30, 14),+    Just $+      Loc+        "путь/Some/Module.hs"+        "main"+        "Some.Module"+        (3000, 9000)+        (4000, 1)   ]  genTypedItems :: [Item AllTypesLogItem] genTypedItems =   [ itemPayload .~ p $ theItem-        | p <- [ AllTypesLogItem "" 0 0.0 [] Nothing-               , AllTypesLogItem "note" 10 5.5 ["one", "two", "three"]-                     (Just dummyLogItem)-               ]+    | p <-+        [ AllTypesLogItem "" 0 0.0 [] Nothing,+          AllTypesLogItem+            "note"+            10+            5.5+            ["one", "two", "three"]+            (Just dummyLogItem)+        ]   ]  mkUTCTime :: Integer -> Int -> Int -> DiffTime -> DiffTime -> DiffTime -> UTCTime@@ -234,23 +268,29 @@  ------------------------------------------------------------------------------- writeTextLog :: (FilePath, Handle) -> IO (BL.ByteString)-writeTextLog (path, h) = do-    mapM_ (put . formatOne) genItems-    mapM_ (put . formatOne) genTypedItems-    hClose h-    BL.readFile path+writeTextLog = writeFormattedLog bracketFormat++writeJsonLog :: (FilePath, Handle) -> IO (BL.ByteString)+writeJsonLog = writeFormattedLog jsonFormat++writeFormattedLog :: (forall a. LogItem a => ItemFormatter a) -> (FilePath, Handle) -> IO (BL.ByteString)+writeFormattedLog format (path, h) = do+  mapM_ (put . formatOne) genItems+  mapM_ (put . formatOne) genTypedItems+  hClose h+  BL.readFile path   where     formatOne :: LogItem a => Item a -> Text-    formatOne = LT.toStrict . LT.toLazyText . formatItem False V3+    formatOne = LT.toStrict . LT.toLazyText . format False V3     put = B.hPutStrLn h . T.encodeUtf8  setupTempFile :: IO (FilePath, Handle) setupTempFile = do-    tempDir <- getTemporaryDirectory-    (fp, h) <- openBinaryTempFile tempDir "katip.log"-    return (fp, h)+  tempDir <- getTemporaryDirectory+  (fp, h) <- openBinaryTempFile tempDir "katip.log"+  return (fp, h)  teardownTempFile :: (FilePath, Handle) -> IO () teardownTempFile (_, h) = do-    chk <- hIsOpen h-    when chk $ hClose h+  chk <- hIsOpen h+  when chk $ hClose h

@@ -1,21 +1,23 @@ module Main (main) where  --------------------------------------------------------------------------------import           Test.Tasty+ ------------------------------------------------------------------------------- import qualified Katip.Tests import qualified Katip.Tests.Format.Time import qualified Katip.Tests.Scribes.Handle--------------------------------------------------------------------------------+import Test.Tasty +-------------------------------------------------------------------------------  main :: IO () main = defaultMain testSuite  testSuite :: TestTree-testSuite = testGroup "katip"-  [-    Katip.Tests.tests-  , Katip.Tests.Format.Time.tests-  , Katip.Tests.Scribes.Handle.tests-  ]+testSuite =+  testGroup+    "katip"+    [ Katip.Tests.tests,+      Katip.Tests.Format.Time.tests,+      Katip.Tests.Scribes.Handle.tests+    ]