benign-katip (empty) → 0.1.0

raw patch · 2 files changed

+116/−0 lines, 2 filesdep +basedep +benigndep +katip

Dependencies added: base, benign, katip

Files

• benign-katip.cabal +33/−0
• src/Benign/Katip.hs +83/−0

@@ -0,0 +1,33 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.38.0.+--+-- see: https://github.com/sol/hpack++name:           benign-katip+version:        0.1.0+synopsis:       A Benign backend for the Katip library+description:    see README.md.+homepage:       https://github.com/aspiwack/haskell-benign#readme+bug-reports:    https://github.com/aspiwack/haskell-benign/issues+author:         Arnaud Spiwack+maintainer:     arnaud@spiwack.net+copyright:      MIT+license:        MIT+build-type:     Simple++source-repository head+  type: git+  location: https://github.com/aspiwack/haskell-benign++library+  exposed-modules:+      Benign.Katip+  hs-source-dirs:+      src+  ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances -Wredundant-constraints+  build-depends:+      base <4.22+    , benign+    , katip+  default-language: Haskell2010

@@ -0,0 +1,83 @@+{-# LANGUAGE GHC2021 #-}++-- | This module is a small wrapper around+-- [Katip](https://hackage.haskell.org/package/katip) to allow logging in pure+-- code.+--+-- The wrapper is a little primitive still and you will have to handle the+-- transition from IO code to pure code manually. Pull requests are, of course,+-- welcome.+module Benign.Katip+  ( withKatipContext,+    withKatipNamespace,+    withKatip,+    logLocM,+  )+where++import Benign qualified+import GHC.Stack+import Katip qualified+import System.IO.Unsafe (unsafePerformIO)+import Prelude++katipEnv :: Benign.Field Katip.LogEnv+katipEnv = unsafePerformIO Benign.newField+{-# NOINLINE katipEnv #-}++katipContext :: Benign.Field Katip.LogContexts+katipContext = unsafePerformIO Benign.newField+{-# NOINLINE katipContext #-}++katipNamespace :: Benign.Field Katip.Namespace+katipNamespace = unsafePerformIO Benign.newField+{-# NOINLINE katipNamespace #-}++-- | See 'Katip.katipAddContext'.+withKatipContext :: (Katip.LogItem i) => i -> Benign.Strat a -> a -> a+withKatipContext item = Benign.withAltering katipContext (<> Just (Katip.liftPayload item))++-- | See 'Katip.katipAddNamespace'.+withKatipNamespace :: Katip.Namespace -> Benign.Strat a -> a -> a+withKatipNamespace namespace = Benign.withAltering katipNamespace (<> Just namespace)++-- | Within this computation, Katip is configured for pure code.+withKatip ::+  (Katip.LogItem c) =>+  Katip.LogEnv ->+  c ->+  Katip.Namespace ->+  Benign.Strat a ->+  IO a ->+  IO a+withKatip env ctx namespace strat =+  Benign.withSettingIO' katipEnv env+    . Benign.withSettingIO' katipContext (Katip.liftPayload ctx)+    . Benign.withSettingIO katipNamespace namespace strat++-- | @'logLocM' s msg a@ logs a an event, like Katip's 'Katip.logLocM', before+-- evaluating @a@.+logLocM :: forall a. (HasCallStack) => Katip.Severity -> Katip.LogStr -> a -> a+logLocM severity str = withFrozenCallStack spanLog+  where+    -- The whole purpose of naming `span` is to freeze the call stack. It's+    -- important to freeze the call site, so that the log is recorded as+    -- happening on the line where `logLocM` was called, not on this file. But+    -- since `HasCallStack` is magical, it's quite possible for the type system+    -- to “lose track” of the current `HasCallStack` and create a new one from+    -- scratch. This would be invisible. I tried to harden this function by+    -- declaring type signatures everywhere. I haven't tested it yet though. It+    -- may be wrong.+    spanLog :: (HasCallStack) => a -> a+    spanLog = Benign.unsafeSpanBenign doLog (return ()) Benign.whnf++    doLog :: (HasCallStack) => IO ()+    doLog = do+      -- Making an intermediary `KatipContextT` is a little roundabout, but it's+      -- easier than reaching to Katip's internals.+      --+      -- TODO: catch errors+      Just env <- Benign.lookupLexicalState katipEnv+      Just ctx <- Benign.lookupLexicalState katipContext+      Just namespace <- Benign.lookupLexicalState katipNamespace+      Katip.runKatipContextT env ctx namespace $ Katip.logLocM severity str