polysemy-log 0.1.0.0 → 0.2.0.0

raw patch · 11 files changed

+268/−10 lines, 11 filesdep +asyncdep +stmdep +stm-chansPVP ok

version bump matches the API change (PVP)

Dependencies added: async, stm, stm-chans

API changes (from Hackage documentation)

Files

• Changelog.md +6/−0
• lib/Polysemy/Log.hs +6/−1
• lib/Polysemy/Log/Atomic.hs +20/−3
• lib/Polysemy/Log/Conc.hs +92/−0
• lib/Polysemy/Log/Data/DataLog.hs +3/−1
• lib/Polysemy/Log/Log.hs +17/−2
• polysemy-log.cabal +10/−1
• readme.md +1/−1
• test/Main.hs +5/−1
• test/Polysemy/Log/Test/ConcTest.hs +49/−0
• test/Polysemy/Log/Test/LocalTest.hs +59/−0

@@ -0,0 +1,6 @@+# 0.2.0.0++* `DataLog` got a second constructor, `Local`. It takes a higher-order `Sem` and a transformation function, the latter+  of which is applied to all messages logged within the former.+  This allows context manipulation for blocks of code.+* `interceptDataLogConc` adds support for concurrent processing of log messages to any interpretation of `DataLog`.

@@ -37,16 +37,21 @@   interpretLogNull,   interpretLogAtomic,   interpretLogAtomic',++  -- * Concurrent Logging+  interceptDataLogConc,+  interpretLogDataLogConc, ) where  import Polysemy.Log.Atomic (interpretDataLogAtomic, interpretDataLogAtomic', interpretLogAtomic, interpretLogAtomic')+import Polysemy.Log.Conc (interceptDataLogConc) import Polysemy.Log.Data.DataLog (DataLog(DataLog), dataLog) import Polysemy.Log.Data.Log (Log(Log), crit, debug, error, info, log, trace, warn) import Polysemy.Log.Data.LogEntry (LogEntry(LogEntry)) import Polysemy.Log.Data.LogMessage (LogMessage(LogMessage)) import Polysemy.Log.Data.Severity (Severity(..)) import Polysemy.Log.Format (formatLogEntry)-import Polysemy.Log.Log (interpretLogDataLog, interpretLogDataLog')+import Polysemy.Log.Log (interpretLogDataLog, interpretLogDataLog', interpretLogDataLogConc) import Polysemy.Log.Pure (interpretLogNull, interpretLogOutput)  -- $intro

@@ -1,20 +1,37 @@ -- |Description: Internal module Polysemy.Log.Atomic where +import Polysemy (interpretH, runT) import Polysemy.Internal (InterpretersFor)+import Polysemy.Internal.Tactics (liftT) -import Polysemy.Log.Data.DataLog (DataLog(DataLog))+import Polysemy.Log.Data.DataLog (DataLog(DataLog, Local)) import Polysemy.Log.Data.Log (Log(Log)) import Polysemy.Log.Data.LogMessage (LogMessage)  -- |Interpret 'DataLog' by prepending each message to a list in an 'AtomicState'.+-- Maintains a context function as state that is applied to each logged message, allowing the context of a block to be+-- modified.+interpretDataLogAtomicLocal ::+  ∀ a r .+  Member (AtomicState [a]) r =>+  (a -> a) ->+  InterpreterFor (DataLog a) r+interpretDataLogAtomicLocal context =+  interpretH \case+    DataLog msg ->+      liftT (atomicModify' (context msg :))+    Local f ma ->+      raise . interpretDataLogAtomicLocal (f . context) =<< runT ma+{-# INLINE interpretDataLogAtomicLocal #-}++-- |Interpret 'DataLog' by prepending each message to a list in an 'AtomicState'. interpretDataLogAtomic' ::   ∀ a r .   Member (AtomicState [a]) r =>   InterpreterFor (DataLog a) r interpretDataLogAtomic' =-  interpret \case-    DataLog msg -> atomicModify' (msg :)+  interpretDataLogAtomicLocal id {-# INLINE interpretDataLogAtomic' #-}  -- |Interpret 'DataLog' by prepending each message to a list in an 'AtomicState', then interpret the 'AtomicState' in a

@@ -0,0 +1,92 @@+-- |Description: Internal+module Polysemy.Log.Conc where++import Control.Concurrent.STM.TBMQueue (TBMQueue, closeTBMQueue, newTBMQueueIO, readTBMQueue, writeTBMQueue)+import Polysemy (interceptH, runT, subsume)+import Polysemy.Async (Async, async)+import Polysemy.Internal.Tactics (liftT)+import Polysemy.Resource (Resource, bracket)++import qualified Polysemy.Log.Data.DataLog as DataLog+import Polysemy.Log.Data.DataLog (DataLog(DataLog, Local))++-- |Intercept 'DataLog' for concurrent processing.+-- This does not send any action to the ultimate interpreter but writes all log messages to the provided queue.+-- 'Local' has to be handled here, otherwise this will not be called for actions in higher-order thunks.+interceptDataLogConcWithLocal ::+  ∀ msg r a .+  Members [DataLog msg, Embed IO] r =>+  (msg -> msg) ->+  TBMQueue msg ->+  Sem r a ->+  Sem r a+interceptDataLogConcWithLocal context queue =+  interceptH \case+    DataLog msg ->+      liftT (atomically (writeTBMQueue queue (context msg)))+    Local f ma ->+      raise . interceptDataLogConcWithLocal (f . context) queue . subsume =<< runT ma+{-# INLINE interceptDataLogConcWithLocal #-}++-- |Intercept 'DataLog' for concurrent processing.+interceptDataLogConcWith ::+  ∀ msg r a .+  Members [DataLog msg, Embed IO] r =>+  TBMQueue msg ->+  Sem r a ->+  Sem r a+interceptDataLogConcWith =+  interceptDataLogConcWithLocal id+{-# INLINE interceptDataLogConcWith #-}++-- |Part of 'interceptDataLogConc'.+-- Loop as long as the proided queue is open and relay all dequeued messages to the ultimate interpreter, thereby+-- forcing the logging implementation to work in this thread.+loggerThread ::+  ∀ msg r .+  Members [DataLog msg, Embed IO] r =>+  TBMQueue msg ->+  Sem r ()+loggerThread queue = do+  spin+  where+    spin =+      atomically (readTBMQueue queue) >>= \case+        Nothing -> pure ()+        Just msg -> do+          DataLog.dataLog @msg msg+          spin++-- |Part of 'interceptDataLogConc'.+-- Create a queue and start a thread that reads messages from it, calling the logging implementation.+acquireQueue ::+  ∀ msg r .+  Members [DataLog msg, Async, Embed IO] r =>+  Int ->+  Sem r (TBMQueue msg)+acquireQueue maxQueued = do+  queue <- embed (newTBMQueueIO maxQueued)+  !_ <- async (loggerThread queue)+  pure queue++-- |Intercept 'DataLog' for concurrent processing.+-- Creates a queue and starts a worker thread.+-- All log messages received by the interceptor in 'interceptDataLogConcWithLocal' are written to the queue and sent to+-- the next 'DataLog' interpreter when the thread reads from the queue.+--+-- Since this is an interceptor, it will not remove the effect from the stack, but relay it to another interpreter:+--+-- @+-- interpretDataLogAtomic (interceptDataLogConc (DataLog.dataLog "message"))+-- @+interceptDataLogConc ::+  ∀ msg r a .+  Members [DataLog msg, Resource, Async, Embed IO] r =>+  -- |Queue size. When the queue fills up, the interceptor will block.+  Int ->+  Sem r a ->+  Sem r a+interceptDataLogConc maxQueued sem = do+  bracket (acquireQueue maxQueued) (atomically . closeTBMQueue) \ queue ->+    interceptDataLogConcWith @msg queue sem+{-# INLINE interceptDataLogConc #-}

@@ -6,9 +6,11 @@ -- |Adapter for a logging backend. -- -- Usually this is reinterpreted into an effect like those from /co-log/ or /di/, but it can be used purely for testing.--- This effect is basically identical to 'Polysemy.Output.Output' and serves only as a nominal component. data DataLog a :: Effect where   -- |Schedule an arbitrary value for logging.   DataLog :: a -> DataLog a m ()+  -- |Stores the provided function in the interpreter and applies it to all log messages emitted within the higher-order+  -- thunk that's the second argument.+  Local :: (a -> a) -> m b -> DataLog a m b  makeSem ''DataLog

@@ -1,9 +1,12 @@ -- |Description: Internal module Polysemy.Log.Log where +import Polysemy.Async (Async) import Polysemy.Internal (InterpretersFor)+import Polysemy.Resource (Resource) import Polysemy.Time (GhcTime, interpretTimeGhc) +import Polysemy.Log.Conc (interceptDataLogConc) import Polysemy.Log.Data.DataLog (DataLog, dataLog) import Polysemy.Log.Data.Log (Log(Log)) import Polysemy.Log.Data.LogEntry (LogEntry, annotate)@@ -53,9 +56,21 @@  -- |Interpret 'Log' into 'DataLog', adding metadata information and wrapping with 'LogEntry'. interpretLogDataLog' ::-  Member (Embed IO) r =>-  Member (DataLog (LogEntry LogMessage)) r =>+  Members [DataLog (LogEntry LogMessage), Embed IO] r =>   InterpretersFor [Log, LogMetadata LogMessage, GhcTime] r interpretLogDataLog' =   interpretLogMetadataDataLog' . interpretLogLogMetadata {-# INLINE interpretLogDataLog' #-}++-- |Interpret 'Log' into 'DataLog' concurrently, adding metadata information and wrapping with 'LogEntry'.+interpretLogDataLogConc ::+  Members [DataLog (LogEntry LogMessage), Resource, Async, Embed IO] r =>+  Int ->+  InterpreterFor Log r+interpretLogDataLogConc maxQueued =+  interceptDataLogConc @(LogEntry LogMessage) maxQueued .+  interpretTimeGhc .+  interpretLogMetadataDataLog @LogMessage .+  interpretLogLogMetadata .+  raiseUnder2+{-# INLINE interpretLogDataLogConc #-}

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           polysemy-log-version:        0.1.0.0+version:        0.2.0.0 synopsis:       Polysemy effects for logging description:    See <https://hackage.haskell.org/package/polysemy-log/docs/Polysemy-Log.html> category:       Logging@@ -29,6 +29,7 @@   exposed-modules:       Polysemy.Log       Polysemy.Log.Atomic+      Polysemy.Log.Conc       Polysemy.Log.Data.DataLog       Polysemy.Log.Data.Log       Polysemy.Log.Data.LogEntry@@ -107,10 +108,13 @@   ghc-options: -flate-specialise -fspecialise-aggressively -Wall -Wredundant-constraints   build-depends:       ansi-terminal >=0.10.0 && <0.11+    , async     , base ==4.*     , polysemy >=1.3 && <1.5     , polysemy-time >=0.1.1.0 && <0.2     , relude >=0.5 && <0.8+    , stm+    , stm-chans     , string-interpolate >=0.2.1     , template-haskell     , text@@ -123,7 +127,9 @@   type: exitcode-stdio-1.0   main-is: Main.hs   other-modules:+      Polysemy.Log.Test.ConcTest       Polysemy.Log.Test.DataLogTest+      Polysemy.Log.Test.LocalTest       Polysemy.Log.Test.LogEntryTest       Polysemy.Log.Test.SimpleTest       Paths_polysemy_log@@ -190,6 +196,7 @@   ghc-options: -flate-specialise -fspecialise-aggressively -Wall -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N   build-depends:       ansi-terminal >=0.10.0 && <0.11+    , async     , base ==4.*     , hedgehog     , polysemy >=1.3 && <1.5@@ -197,6 +204,8 @@     , polysemy-test     , polysemy-time >=0.1.1.0 && <0.2     , relude >=0.5 && <0.8+    , stm+    , stm-chans     , string-interpolate >=0.2.1     , tasty     , tasty-hedgehog

@@ -1,6 +1,6 @@ > Log thrice, debug once. >-> –– Любенов Г.+> –– Г. Любенов  # About 

@@ -1,6 +1,8 @@ module Main where +import Polysemy.Log.Test.ConcTest (test_conc) import Polysemy.Log.Test.DataLogTest (test_dataLog)+import Polysemy.Log.Test.LocalTest (test_local) import Polysemy.Log.Test.LogEntryTest (test_logEntry) import Polysemy.Log.Test.SimpleTest (test_simple) import Polysemy.Test (unitTest)@@ -11,7 +13,9 @@   testGroup "core" [     unitTest "simple" test_simple,     unitTest "data" test_dataLog,-    unitTest "entry" test_logEntry+    unitTest "local" test_local,+    unitTest "entry" test_logEntry,+    unitTest "conc" test_conc     ]  main :: IO ()

@@ -0,0 +1,49 @@+module Polysemy.Log.Test.ConcTest where++import Data.Time (Day, UTCTime)+import Polysemy.Async (asyncToIOFinal)+import Polysemy.Test (UnitTest, assertEq, runTestAuto)+import qualified Polysemy.Time as Time+import Polysemy.Time (GhcTime, MilliSeconds(MilliSeconds), interpretTimeGhc)++import Polysemy.Log.Atomic (interpretDataLogAtomic)+import Polysemy.Log.Conc (interceptDataLogConc)+import qualified Polysemy.Log.Data.DataLog as DataLog+import Polysemy.Log.Data.DataLog (DataLog)++data Context =+  Context {+    context :: [Text],+    message :: Text+  }+  deriving (Eq, Show)++prog ::+  Members [DataLog Context, GhcTime, AtomicState [Context]] r =>+  Sem r [Context]+prog = do+  DataLog.dataLog (Context [] "1")+  DataLog.local push do+    DataLog.dataLog (Context [] "2")+    DataLog.dataLog (Context [] "3")+  DataLog.dataLog (Context [] "4")+  Time.sleep @UTCTime @Day (MilliSeconds 100)+  atomicGet+  where+    push (Context c m) =+      Context ("context" : c) m++target :: [Context]+target =+  [Context [] "4", Context ["context"] "3", Context ["context"] "2", Context [] "1"]++test_conc :: UnitTest+test_conc =+  runTestAuto do+    msgs <-+      asyncToIOFinal $+      interpretTimeGhc $+      interpretDataLogAtomic @Context $+      interceptDataLogConc @Context 1 $+      prog+    assertEq @_ @IO target msgs

@@ -0,0 +1,59 @@+module Polysemy.Log.Test.LocalTest where++import Polysemy.Test (UnitTest, assertEq, runTestAuto)++import Polysemy.Log.Atomic (interpretDataLogAtomic)+import qualified Polysemy.Log.Data.DataLog as DataLog+import Polysemy.Log.Data.DataLog (DataLog)+import Polysemy.Log.Data.LogMessage (LogMessage(LogMessage))+import Polysemy.Log.Data.Severity (Severity(Debug))++data Context =+  Context {+    context :: [Text],+    message :: LogMessage+  }+  deriving (Eq, Show)++log ::+  Member (DataLog Context) r =>+  Severity ->+  Text ->+  Sem r ()+log severity msg =+  DataLog.dataLog (Context [] (LogMessage severity msg))++pushContext ::+  Member (DataLog Context) r =>+  [Text] ->+  Sem r a ->+  Sem r a+pushContext ctx =+  DataLog.local push+  where+    push (Context c m) =+      Context (ctx <> c) m++prog ::+  Members [DataLog Context, AtomicState [Context]] r =>+  Sem r [Context]+prog = do+  log Debug "0"+  pushContext ["level2", "level1"] do+    log Debug "2"+    pushContext ["level3"] do+      log Debug "3"+  atomicGet++target :: [Context]+target =+  [+    Context ["level3", "level2", "level1"] (LogMessage Debug "3"),+    Context ["level2", "level1"] (LogMessage Debug "2"),+    Context [] (LogMessage Debug "0")+  ]++test_local :: UnitTest+test_local =+  runTestAuto do+    assertEq @_ @IO target =<< interpretDataLogAtomic @Context prog