extensible-effects-concurrent 0.7.0 → 0.7.1

raw patch · 4 files changed

+97/−63 lines, 4 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +5/−0
• extensible-effects-concurrent.cabal +1/−1
• src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +32/−23
• src/Control/Eff/Log/Message.hs +59/−39

@@ -1,5 +1,10 @@ # Changelog for extensible-effects-concurrent +## 0.7.1++- Improve call-stack support in log messages+- Expose `setLogMessageTimestamp` and `setLogMessageThreadId`+ ## 0.7.0  - Remove the parameter from `closeLogChannelAfter` that had the optional:

@@ -1,5 +1,5 @@ name:           extensible-effects-concurrent-version:        0.7.0+version:        0.7.1 description:    Please see the README on GitHub at <https://github.com/sheyll/extensible-effects-concurrent#readme> synopsis:       Message passing concurrency as extensible-effect homepage:       https://github.com/sheyll/extensible-effects-concurrent#readme

@@ -127,17 +127,21 @@ -- | This is the main entry point to running a message passing concurrency -- application. This function takes a 'Process' on top of the 'SchedulerIO' -- effect and a 'LogChannel' for concurrent logging.-schedule :: Eff (ConsProcess SchedulerIO) () -> LogChannel LogMessage -> IO ()+schedule+  :: HasCallStack+  => Eff (ConsProcess SchedulerIO) ()+  -> LogChannel LogMessage+  -> IO () schedule e logC = void $ withNewSchedulerState $ \schedulerStateVar -> do   pidVar <- newEmptyTMVarIO-  scheduleProcessWithShutdownAction schedulerStateVar pidVar $ do-    mt <- lift myThreadId-    mp <- lift (atomically (readTMVar pidVar))-    logInfo (show mp ++ " main process started in thread " ++ show mt)-    e-    logInfo (show mp ++ " main process returned")+  scheduleProcessWithShutdownAction schedulerStateVar pidVar+    $ interceptLogging (setLogMessageThreadId >=> logMsg)+    $ do+        logNotice "++++++++ main process started ++++++++"+        e+        logNotice "++++++++ main process returned ++++++++"  where-  withNewSchedulerState :: (SchedulerVar -> IO a) -> IO a+  withNewSchedulerState :: HasCallStack => (SchedulerVar -> IO a) -> IO a   withNewSchedulerState mainProcessAction = do     myTId <- myThreadId     Exc.bracket (newTVarIO (Scheduler myPid Map.empty Map.empty False logC))@@ -146,7 +150,7 @@    where     myPid = 1     tearDownScheduler myTId v = do-      logChannelPutIO logC (debugMessage "begin scheduler tear down")+      logChannelPutIO logC =<< debugMessageIO "begin scheduler tear down"       sch <-         (atomically           (do@@ -156,16 +160,14 @@             return sch'           )         )-      logChannelPutIO-        logC-        (debugMessage-          (  "killing "-          ++ let ts = (sch ^.. threadIdTable . traversed)-             in  if length ts > 100-                   then show (length ts) ++ " threads"-                   else show ts-          )+      logChannelPutIO logC =<< debugMessageIO+        (  "killing "+        ++ let ts = (sch ^.. threadIdTable . traversed)+           in  if length ts > 100+                 then show (length ts) ++ " threads"+                 else show ts         )+       imapM_ (killProcThread myTId) (sch ^. threadIdTable)       Concurrent.yield       atomically@@ -180,13 +182,13 @@                   .  to Map.null           STM.check allThreadsDead         )-      logChannelPutIO logC (infoMessage "all threads dead")+      logChannelPutIO logC =<< infoMessageIO "all threads dead"      killProcThread myTId _pid tid = when (myTId /= tid) (killThread tid)  -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output.-defaultMain :: Eff (ConsProcess SchedulerIO) () -> IO ()+defaultMain :: HasCallStack => Eff (ConsProcess SchedulerIO) () -> IO () defaultMain c = runLoggingT   (logChannelBracket 128                      (Just (infoMessage "main process started"))@@ -197,11 +199,15 @@ -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output. defaultMainWithLogChannel-  :: LogChannel LogMessage -> Eff (ConsProcess SchedulerIO) () -> IO ()+  :: HasCallStack+  => LogChannel LogMessage+  -> Eff (ConsProcess SchedulerIO) ()+  -> IO () defaultMainWithLogChannel logC c = closeLogChannelAfter logC (schedule c logC)  scheduleProcessWithShutdownAction-  :: SchedulerVar+  :: HasCallStack+  => SchedulerVar   -> STM.TMVar ProcessId   -> Eff (ConsProcess SchedulerIO) ()   -> IO (Either Exc.SomeException ())@@ -239,7 +245,10 @@           )         )       interceptLogging-          (logMsg . over lmMessage (printf "[PID %7i] %s" (toInteger pid)))+          (setLogMessageThreadId >=> logMsg . over+            lmMessage+            (printf "% 9s %s" (show pid))+          )         $ do             logDebug "begin process"             procAction

@@ -65,6 +65,8 @@   , lmThreadId   , lmMessage   , setCallStack+  , setLogMessageTimestamp+  , setLogMessageThreadId   , StructuredDataElement(..)   , sdElementId   , sdElementParameters@@ -85,6 +87,7 @@ import           Control.Concurrent import           GHC.Generics import           Text.Printf+import           System.FilePath.Posix import           Control.Monad                  ( (>=>) )  -- | A message data type inspired by the RFC-5424 Syslog Protocol@@ -108,8 +111,16 @@     then []     else       maybe "" (printf "[%s]" . show) ti-      : msg-      : maybe [] (pure . prettySrcLoc) loc+      : (msg ++ replicate (max 0 (60 - length msg)) ' ')+      : maybe+          []+          (\sl -> pure+            (printf "% 30s line %i"+                    (takeFileName (srcLocFile sl))+                    (srcLocStartLine sl)+            )+          )+          loc   -- | Render a 'LogMessage' human readable.@@ -212,18 +223,14 @@   (_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc  instance Default LogMessage where-  def = setCallStack callStack (LogMessage def def def def def def def def def def "")+  def = LogMessage def def def def def def def def def def ""  instance IsString LogMessage where   fromString = infoMessage  -- | Render a 'LogMessage' but set the timestamp and thread id fields. printLogMessage :: LogMessage -> IO ()-printLogMessage =-  setLogMessageTimestamp-    >=> setLogMessageThreadId-    >=> putStrLn-    .   renderLogMessage+printLogMessage = setLogMessageTimestamp >=> putStrLn . renderLogMessage  -- | An IO action that sets the current UTC time (see 'enableLogMessageTimestamps') -- in 'lmTimestamp'.@@ -242,57 +249,63 @@ -- | Handle a 'Logs' effect for 'String' messages by re-logging the messages -- as 'LogMessage's with 'debugSeverity'. relogAsDebugMessages-  :: Member (Logs LogMessage) e => Eff (Logs String ': e) a -> Eff e a-relogAsDebugMessages = withFrozenCallStack . handleLogsWith logDebug+  :: (HasCallStack, Member (Logs LogMessage) e)+  => Eff (Logs String ': e) a+  -> Eff e a+relogAsDebugMessages = withFrozenCallStack (handleLogsWith logDebug)  -- | Log a 'String' as 'LogMessage' with a given 'Severity'.-logWithSeverity :: Member (Logs LogMessage) e => Severity -> String -> Eff e ()-logWithSeverity s =+logWithSeverity+  :: (HasCallStack, Member (Logs LogMessage) e)+  => Severity+  -> String+  -> Eff e ()+logWithSeverity !s =   withFrozenCallStack-    . logMsg+    $ logMsg     . setCallStack callStack     . set lmSeverity s     . flip (set lmMessage) def  -- | Log a 'String' as 'emergencySeverity'.-logEmergency :: Member (Logs LogMessage) e => String -> Eff e ()-logEmergency = withFrozenCallStack . logWithSeverity emergencySeverity+logEmergency :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()+logEmergency = withFrozenCallStack (logWithSeverity emergencySeverity)  -- | Log a message with 'alertSeverity'.-logAlert :: Member (Logs LogMessage) e => String -> Eff e ()-logAlert = withFrozenCallStack . logWithSeverity alertSeverity+logAlert :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()+logAlert = withFrozenCallStack (logWithSeverity alertSeverity)  -- | Log a 'criticalSeverity' message.-logCritical :: Member (Logs LogMessage) e => String -> Eff e ()-logCritical = withFrozenCallStack . logWithSeverity criticalSeverity+logCritical :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()+logCritical = withFrozenCallStack (logWithSeverity criticalSeverity)  -- | Log a 'errorSeverity' message.-logError :: Member (Logs LogMessage) e => String -> Eff e ()-logError = withFrozenCallStack . logWithSeverity errorSeverity+logError :: HasCallStack => Member (Logs LogMessage) e => String -> Eff e ()+logError = withFrozenCallStack (logWithSeverity errorSeverity)  -- | Log a 'warningSeverity' message.-logWarning :: Member (Logs LogMessage) e => String -> Eff e ()-logWarning = withFrozenCallStack . logWithSeverity warningSeverity+logWarning :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()+logWarning = withFrozenCallStack (logWithSeverity warningSeverity)  -- | Log a 'noticeSeverity' message.-logNotice :: Member (Logs LogMessage) e => String -> Eff e ()-logNotice = withFrozenCallStack . logWithSeverity noticeSeverity+logNotice :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()+logNotice = withFrozenCallStack (logWithSeverity noticeSeverity)  -- | Log a 'informationalSeverity' message.-logInfo :: Member (Logs LogMessage) e => String -> Eff e ()-logInfo = withFrozenCallStack . logWithSeverity informationalSeverity+logInfo :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()+logInfo = withFrozenCallStack (logWithSeverity informationalSeverity)  -- | Log a 'debugSeverity' message.-logDebug :: Member (Logs LogMessage) e => String -> Eff e ()-logDebug = withFrozenCallStack . logWithSeverity debugSeverity+logDebug :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()+logDebug = withFrozenCallStack (logWithSeverity debugSeverity)  -- | Construct a 'LogMessage' with 'errorSeverity'-errorMessage :: String -> LogMessage+errorMessage :: HasCallStack => String -> LogMessage errorMessage m = withFrozenCallStack   (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack)  -- | Construct a 'LogMessage' with 'informationalSeverity'-infoMessage :: String -> LogMessage+infoMessage :: HasCallStack => String -> LogMessage infoMessage m = withFrozenCallStack   (  def   &  lmSeverity@@ -303,23 +316,30 @@   )  -- | Construct a 'LogMessage' with 'debugSeverity'-debugMessage :: String -> LogMessage+debugMessage :: HasCallStack => String -> LogMessage debugMessage m = withFrozenCallStack   (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack)  -- | Construct a 'LogMessage' with 'errorSeverity'-errorMessageIO :: MonadIO m => String -> m LogMessage+errorMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage errorMessageIO =-  (setLogMessageThreadId >=> setLogMessageTimestamp) . errorMessage+  withFrozenCallStack+    $ (setLogMessageThreadId >=> setLogMessageTimestamp)+    . errorMessage+ -- | Construct a 'LogMessage' with 'informationalSeverity'-infoMessageIO :: MonadIO m => String -> m LogMessage+infoMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage infoMessageIO =-  (setLogMessageThreadId >=> setLogMessageTimestamp) . infoMessage+  withFrozenCallStack+    $ (setLogMessageThreadId >=> setLogMessageTimestamp)+    . infoMessage+ -- | Construct a 'LogMessage' with 'debugSeverity'-debugMessageIO :: MonadIO m => String -> m LogMessage+debugMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage debugMessageIO =-  (setLogMessageThreadId >=> setLogMessageTimestamp) . debugMessage-+  withFrozenCallStack+    $ (setLogMessageThreadId >=> setLogMessageTimestamp)+    . debugMessage  emergencySeverity :: Severity emergencySeverity = Severity 0