extensible-effects-concurrent 0.5.0.1 → 0.6.0

raw patch · 16 files changed

+1054/−900 lines, 16 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−1
• extensible-effects-concurrent.cabal +6/−5
• src/Control/Eff/Concurrent/Api/Observer.hs +86/−76
• src/Control/Eff/Concurrent/Examples.hs +84/−84
• src/Control/Eff/Concurrent/Examples2.hs +14/−14
• src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +59/−48
• src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs +11/−7
• src/Control/Eff/Log.hs +6/−332
• src/Control/Eff/Log/Channel.hs +193/−0
• src/Control/Eff/Log/Handler.hs +137/−0
• src/Control/Eff/Log/Message.hs +421/−0
• src/Control/Eff/Log/MessageFactory.hs +0/−56
• src/Control/Eff/Log/Syslog.hs +0/−249
• test/Common.hs +11/−12
• test/LoggingTests.hs +3/−0
• test/ProcessBehaviourTestCases.hs +16/−16

@@ -1,11 +1,17 @@ # Changelog for extensible-effects-concurrent ++## 0.6.0++- Rewrite Logging+- Improve Experimental Nix expressions+ ## 0.5.0.0  - Switch to `extensible-effects` version `3.1.0.0` - Bump to stackage LTS-12.9 - Add `Control.Eff.Log.MessageFactory`-- Add `Control.Eff.Log.Syslog`+- Add `Control.Eff.Log.Message`  ## 0.4.0.0 

@@ -1,12 +1,12 @@ name:           extensible-effects-concurrent-version:        0.5.0.1+version:        0.6.0 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 bug-reports:    https://github.com/sheyll/extensible-effects-concurrent/issues-author:         Sven Heyll                +author:         Sven Heyll maintainer:     sven.heyll@gmail.com-category:       Concurrency                +category:       Concurrency copyright:      Copyright Sven Heyll license:        BSD3 license-file:   LICENSE@@ -57,8 +57,9 @@                   Control.Eff.Loop,                   Control.Eff.ExceptionExtra,                   Control.Eff.Log,-                  Control.Eff.Log.Syslog,-                  Control.Eff.Log.MessageFactory,+                  Control.Eff.Log.Channel,+                  Control.Eff.Log.Handler,+                  Control.Eff.Log.Message,                   Control.Eff.Concurrent,                   Control.Eff.Concurrent.Api,                   Control.Eff.Concurrent.Api.Client,

@@ -22,21 +22,22 @@   , CallbackObserver   , spawnCallbackObserver   , spawnLoggingObserver-  ) where+  )+where -import GHC.Stack-import Data.Dynamic-import Data.Set (Set)-import qualified Data.Set as Set-import Control.Eff-import Control.Eff.Concurrent.Process-import Control.Eff.Concurrent.Api-import Control.Eff.Concurrent.Api.Client-import Control.Eff.Concurrent.Api.Server-import Control.Eff.Log-import Control.Eff.State.Strict-import Control.Lens-import Control.Monad+import           GHC.Stack+import           Data.Dynamic+import           Data.Set                       ( Set )+import qualified Data.Set                      as Set+import           Control.Eff+import           Control.Eff.Concurrent.Process+import           Control.Eff.Concurrent.Api+import           Control.Eff.Concurrent.Api.Client+import           Control.Eff.Concurrent.Api.Server+import           Control.Eff.Log+import           Control.Eff.State.Strict+import           Control.Lens+import           Control.Monad  -- | An 'Api' index that support observation of the -- another 'Api' that is 'Observable'.@@ -57,30 +58,33 @@   forgetObserverMessage :: SomeObserver o -> Api o 'Asynchronous  -- | Send an 'Observation' to an 'Observer'-notifyObserver :: ( SetMember Process (Process q) r-                 , Observable o-                 , Observer p o-                 , HasCallStack-                 )-               => SchedulerProxy q -> Server p -> Server o -> Observation o -> Eff r ()+notifyObserver+  :: (SetMember Process (Process q) r, Observable o, Observer p o, HasCallStack)+  => SchedulerProxy q+  -> Server p+  -> Server o+  -> Observation o+  -> Eff r () notifyObserver px observer observed observation =   cast px observer (observationMessage observed observation)  -- | Send the 'registerObserverMessage'-registerObserver :: ( SetMember Process (Process q) r-                 , Observable o-                 , Observer p o-                 , HasCallStack-                 )-               => SchedulerProxy q -> Server p -> Server o -> Eff r ()+registerObserver+  :: (SetMember Process (Process q) r, Observable o, Observer p o, HasCallStack)+  => SchedulerProxy q+  -> Server p+  -> Server o+  -> Eff r () registerObserver px observer observed =   cast px observed (registerObserverMessage (SomeObserver observer))  -- | Send the 'forgetObserverMessage'-forgetObserver :: ( SetMember Process (Process q) r-                , Observable o-                , Observer p o)-              => SchedulerProxy q -> Server p -> Server o -> Eff r ()+forgetObserver+  :: (SetMember Process (Process q) r, Observable o, Observer p o)+  => SchedulerProxy q+  -> Server p+  -> Server o+  -> Eff r () forgetObserver px observer observed =   cast px observed (forgetObserverMessage (SomeObserver observer)) @@ -101,15 +105,13 @@     o1 == o2  -- | Send an 'Observation' to 'SomeObserver'.-notifySomeObserver :: ( SetMember Process (Process q) r-                     , Observable o-                     , HasCallStack-                     )-                   => SchedulerProxy q-                   -> Server o-                   -> Observation o-                   -> SomeObserver o-                   -> Eff r ()+notifySomeObserver+  :: (SetMember Process (Process q) r, Observable o, HasCallStack)+  => SchedulerProxy q+  -> Server o+  -> Observation o+  -> SomeObserver o+  -> Eff r () notifySomeObserver px observed observation (SomeObserver observer) =   notifyObserver px observer observed observation @@ -130,27 +132,34 @@ -- | Add an 'Observer' to the 'Observers' managed by 'manageObservers'. addObserver   :: ( SetMember Process (Process q) r-    , Member (State (Observers o)) r-    , Observable o)-  => SomeObserver o -> Eff r ()+     , Member (State (Observers o)) r+     , Observable o+     )+  => SomeObserver o+  -> Eff r () addObserver = modify . over observers . Set.insert  -- | Delete an 'Observer' from the 'Observers' managed by 'manageObservers'. removeObserver-  ::  ( SetMember Process (Process q) r-    , Member (State (Observers o)) r-    , Observable o)-  => SomeObserver o -> Eff r ()+  :: ( SetMember Process (Process q) r+     , Member (State (Observers o)) r+     , Observable o+     )+  => SomeObserver o+  -> Eff r () removeObserver = modify . over observers . Set.delete   -- | Send an 'Observation' to all 'SomeObserver's in the 'Observers' state. notifyObservers   :: forall o r q-    . ( Observable o-      , SetMember Process (Process q) r-      , Member (State (Observers o)) r)-  => SchedulerProxy q -> Observation o -> Eff r ()+   . ( Observable o+     , SetMember Process (Process q) r+     , Member (State (Observers o)) r+     )+  => SchedulerProxy q+  -> Observation o+  -> Eff r () notifyObservers px observation = do   me <- asServer @o <$> self px   os <- view observers <$> get@@ -173,29 +182,29 @@ -- | Start a new process for an 'Observer' that schedules -- all observations to an effectful callback. spawnCallbackObserver-  :: forall o r q .-  ( SetMember Process (Process q) r-  , Typeable o-  , Show (Observation o)-  , Observable o-  , Member (Logs String) q)+  :: forall o r q+   . ( SetMember Process (Process q) r+     , Typeable o+     , Show (Observation o)+     , Observable o+     , Member (Logs LogMessage) q+     )   => SchedulerProxy q   -> (Server o -> Observation o -> Eff (Process q ': q) Bool)   -> Eff r (Server (CallbackObserver o)) spawnCallbackObserver px onObserve =   asServer @(CallbackObserver o)-  <$>-  (spawn @r @q $ do-      let loopUntil =-            serve px-            (ApiHandler @(CallbackObserver o)-              (handleCast loopUntil)-              (unhandledCallError px)-              (defaultTermination px))-      loopUntil)+    <$> (spawn @r @q $ do+          let loopUntil = serve+                px+                (ApiHandler @(CallbackObserver o) (handleCast loopUntil)+                                                  (unhandledCallError px)+                                                  (defaultTermination px)+                )+          loopUntil+        )  where-   handleCast k (CbObserved fromSvr v) =-     onObserve fromSvr v >>= flip when k+  handleCast k (CbObserved fromSvr v) = onObserve fromSvr v >>= flip when k  -- | Use 'spawnCallbackObserver' to create a universal logging observer, -- using the 'Show' instance of the 'Observation'.@@ -204,14 +213,15 @@ -- -- @since 0.3.0.0 spawnLoggingObserver-  :: forall o r q .-  ( SetMember Process (Process q) r-  , Typeable o-  , Show (Observation o)-  , Observable o-  , Member (Logs String) q)+  :: forall o r q+   . ( SetMember Process (Process q) r+     , Typeable o+     , Show (Observation o)+     , Observable o+     , Member (Logs LogMessage) q+     )   => SchedulerProxy q   -> Eff r (Server (CallbackObserver o))-spawnLoggingObserver px =-  spawnCallbackObserver px-  (\s o -> logMsg (show s ++ " OBSERVED: " ++ show o) >> return True)+spawnLoggingObserver px = spawnCallbackObserver+  px+  (\s o -> logDebug (show s ++ " OBSERVED: " ++ show o) >> return True)

@@ -1,13 +1,13 @@ -- | A complete example for the library module Control.Eff.Concurrent.Examples where -import GHC.Stack-import Control.Eff-import Control.Eff.Lift-import Control.Monad-import Data.Dynamic-import Control.Eff.Concurrent-import qualified Control.Exception as Exc+import           GHC.Stack+import           Control.Eff+import           Control.Eff.Lift+import           Control.Monad+import           Data.Dynamic+import           Control.Eff.Concurrent+import qualified Control.Exception             as Exc  data TestApi   deriving Typeable@@ -30,100 +30,100 @@ main = defaultMain (example forkIoScheduler)  mainProcessSpawnsAChildAndReturns-  :: ( HasCallStack, SetMember Process (Process q) r)-  => SchedulerProxy q -> Eff r ()-mainProcessSpawnsAChildAndReturns px =-  void (spawn (void (receiveMessage px)))+  :: (HasCallStack, SetMember Process (Process q) r)+  => SchedulerProxy q+  -> Eff r ()+mainProcessSpawnsAChildAndReturns px = void (spawn (void (receiveMessage px)))  example   :: ( HasCallStack-    , SetMember Process (Process q) r-    , Member (Logs String) r-    , Member (Logs String) q-    , SetMember Lift (Lift IO) q-    , SetMember Lift (Lift IO) r)-  => SchedulerProxy q -> Eff r ()+     , SetMember Process (Process q) r+     , Member (Logs LogMessage) r+     , Member (Logs LogMessage) q+     , SetMember Lift (Lift IO) q+     , SetMember Lift (Lift IO) r+     )+  => SchedulerProxy q+  -> Eff r () example px = do   me <- self px-  logMsg ("I am " ++ show me)+  logInfo ("I am " ++ show me)   server <- asServer @TestApi <$> spawn testServerLoop-  logMsg ("Started server " ++ show server)+  logInfo ("Started server " ++ show server)   let go = do         x <- lift getLine         case x of-          ('k':rest) -> do+          ('k' : rest) -> do             callRegistered px (TerminateError rest)             go-          ('s':_) -> do+          ('s' : _) -> do             callRegistered px Terminate             go-          ('c':_) -> do+          ('c' : _) -> do             castRegistered px (Shout x)             go-          ('r':rest) -> do-            void (replicateM-                  (read rest)-                  (castRegistered px (Shout x)))+          ('r' : rest) -> do+            void (replicateM (read rest) (castRegistered px (Shout x)))             go-          ('q':_) ->-            logMsg "Done."-          _ ->-            do res <- ignoreProcessError px (callRegistered px (SayHello x))-               logMsg ("Result: " ++ show res)-               go+          ('q' : _) -> logInfo "Done."+          _         -> do+            res <- ignoreProcessError px (callRegistered px (SayHello x))+            logInfo ("Result: " ++ show res)+            go   registerServer server go  testServerLoop-  :: forall r .-    (HasCallStack-    , Member (Logs String) r-    , SetMember Lift (Lift IO) r)+  :: forall r+   . (HasCallStack, Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)   => Eff (Process r ': r) ()-testServerLoop =-    serve px $ ApiHandler handleCast handleCall handleTerminate-  where-    px :: SchedulerProxy r-    px = SchedulerProxy-    handleCast :: Api TestApi 'Asynchronous -> Eff (Process r ': r) ()-    handleCast (Shout x) = do-      me <- self px-      logMsg (show me ++ " Shouting: " ++ x)-    handleCall :: Api TestApi ('Synchronous x) -> (x -> Eff (Process r ': r) ()) -> Eff (Process r ': r) ()-    handleCall (SayHello "e1") _reply = do-      me <- self px-      logMsg (show me ++ " raising an error")-      raiseError px "No body loves me... :,("-    handleCall (SayHello "e2") _reply = do-      me <- self px-      logMsg (show me ++ " throwing a MyException ")-      lift (Exc.throw MyException)-    handleCall (SayHello "self") reply = do-      me <- self px-      logMsg (show me ++ " casting to self")-      cast px (asServer @TestApi me) (Shout "from me")-      void (reply False)-    handleCall (SayHello "die") reply = do-      me <- self px-      logMsg (show me ++ " throwing and catching ")-      catchRaisedError px-        (\ er -> logMsg ("WOW: " ++ show er ++ " - No. This is wrong!"))-        (raiseError px "No body loves me... :,(")-      void (reply True)-    handleCall (SayHello x) reply = do-      me <- self px-      logMsg (show me ++ " Got Hello: " ++ x)-      void (reply (length x > 3))-    handleCall Terminate reply = do-      me <- self px-      logMsg (show me ++ " exiting")-      void (reply ())-      exitNormally px-    handleCall (TerminateError msg) reply = do-      me <- self px-      logMsg (show me ++ " exiting with error: " ++ msg)-      void (reply ())-      exitWithError px msg-    handleTerminate msg = do-      me <- self px-      logMsg (show me ++ " is exiting: " ++ show msg)-      maybe (exitNormally px) (exitWithError px) msg+testServerLoop = serve px $ ApiHandler handleCast handleCall handleTerminate+ where+  px :: SchedulerProxy r+  px = SchedulerProxy+  handleCast :: Api TestApi 'Asynchronous -> Eff (Process r ': r) ()+  handleCast (Shout x) = do+    me <- self px+    logInfo (show me ++ " Shouting: " ++ x)+  handleCall+    :: Api TestApi ( 'Synchronous x)+    -> (x -> Eff (Process r ': r) ())+    -> Eff (Process r ': r) ()+  handleCall (SayHello "e1") _reply = do+    me <- self px+    logInfo (show me ++ " raising an error")+    raiseError px "No body loves me... :,("+  handleCall (SayHello "e2") _reply = do+    me <- self px+    logInfo (show me ++ " throwing a MyException ")+    lift (Exc.throw MyException)+  handleCall (SayHello "self") reply = do+    me <- self px+    logInfo (show me ++ " casting to self")+    cast px (asServer @TestApi me) (Shout "from me")+    void (reply False)+  handleCall (SayHello "die") reply = do+    me <- self px+    logInfo (show me ++ " throwing and catching ")+    catchRaisedError+      px+      (\er -> logInfo ("WOW: " ++ show er ++ " - No. This is wrong!"))+      (raiseError px "No body loves me... :,(")+    void (reply True)+  handleCall (SayHello x) reply = do+    me <- self px+    logInfo (show me ++ " Got Hello: " ++ x)+    void (reply (length x > 3))+  handleCall Terminate reply = do+    me <- self px+    logInfo (show me ++ " exiting")+    void (reply ())+    exitNormally px+  handleCall (TerminateError msg) reply = do+    me <- self px+    logInfo (show me ++ " exiting with error: " ++ msg)+    void (reply ())+    exitWithError px msg+  handleTerminate msg = do+    me <- self px+    logInfo (show me ++ " is exiting: " ++ show msg)+    maybe (exitNormally px) (exitWithError px) msg

@@ -36,14 +36,14 @@   forgetObserverMessage = UnobserveCounter  logCounterObservations-  :: (SetMember Process (Process q) r, Member (Logs String) q)+  :: (SetMember Process (Process q) r, Member (Logs LogMessage) q)   => SchedulerProxy q   -> Eff r (Server (CallbackObserver Counter)) logCounterObservations px = spawnCallbackObserver   px   (\fromSvr msg -> do     me <- self px-    logMsg (show me ++ " observed on: " ++ show fromSvr ++ ": " ++ show msg)+    logInfo (show me ++ " observed on: " ++ show fromSvr ++ ": " ++ show msg)     return True   ) @@ -51,7 +51,7 @@   :: forall r q    . ( Member (State (Observers Counter)) r      , Member (State Integer) r-     , Member (Logs String) r+     , Member (Logs LogMessage) r      , SetMember Process (Process q) r      )   => SchedulerProxy q@@ -64,14 +64,14 @@   handleCast (ObserveCounter   o) = addObserver o   handleCast (UnobserveCounter o) = removeObserver o   handleCast Inc                  = do-    logMsg "Inc"+    logInfo "Inc"     modify (+ (1 :: Integer))     currentCount <- get     notifyObservers px (CountChanged currentCount)   handleCall :: Api Counter ( 'Synchronous x) -> (x -> Eff r ()) -> Eff r ()   handleCall Cnt reply = do     c <- get-    logMsg ("Cnt is " ++ show c)+    logInfo ("Cnt is " ++ show c)     reply c  -- * Second API@@ -87,7 +87,7 @@ pocketCalcHandler   :: forall r q    . ( Member (State Integer) r-     , Member (Logs String) r+     , Member (Logs LogMessage) r      , SetMember Process (Process q) r      )   => SchedulerProxy q@@ -98,21 +98,21 @@  where   handleCast :: Api PocketCalc 'Asynchronous -> Eff r ()   handleCast (AAdd x) = do-    logMsg ("AsyncAdd " ++ show x)+    logInfo ("AsyncAdd " ++ show x)     modify (+ x)     c <- get @Integer-    logMsg ("Accumulator is " ++ show c)+    logInfo ("Accumulator is " ++ show c)   handleCall :: Api PocketCalc ( 'Synchronous x) -> (x -> Eff r ()) -> Eff r ()   handleCall (Add x) reply = do-    logMsg ("Add " ++ show x)+    logInfo ("Add " ++ show x)     modify (+ x)     c <- get-    logMsg ("Accumulator is " ++ show c)+    logInfo ("Accumulator is " ++ show c)     reply c  serverLoop   :: forall r q-   . (Member (Logs String) r, SetMember Process (Process q) r)+   . (Member (Logs LogMessage) r, SetMember Process (Process q) r)   => SchedulerProxy q   -> Eff r () serverLoop px = evalState @Integer@@ -124,8 +124,8 @@  -- ** Counter client counterExample-  :: ( Member (Logs String) r-     , Member (Logs String) q+  :: ( Member (Logs LogMessage) r+     , Member (Logs LogMessage) q      , SetMember Process (Process q) r      )   => SchedulerProxy q@@ -133,7 +133,7 @@ counterExample px = do   let cnt sv = do         r <- call px sv Cnt-        logMsg (show sv ++ " " ++ show r)+        logInfo (show sv ++ " " ++ show r)   pid1 <- spawn (serverLoop px)   pid2 <- spawn (serverLoop px)   let cntServer1  = asServer @Counter pid1

@@ -40,15 +40,18 @@ import           Control.Eff.Lift import           Control.Eff.Log import           Control.Eff.Reader.Strict     as Reader+import           Control.Monad.Log              ( runLoggingT ) import           Control.Lens import           Control.Monad                  ( when                                                 , void                                                 , join+                                                , (>=>)                                                 ) import qualified Control.Monad.State           as Mtl import           Data.Dynamic import           Data.Map                       ( Map ) import qualified Data.Map                      as Map+import           Text.Printf import           Data.String  -- | Information about a process, needed to implement 'MessagePassing' and@@ -73,7 +76,7 @@                           , _processTable :: Map ProcessId ProcessInfo                           , _threadIdTable :: Map ProcessId ThreadId                           , _schedulerShuttingDown :: Bool-                          , _logChannel :: LogChannel String+                          , _logChannel :: LogChannel LogMessage                           }  makeLenses ''Scheduler@@ -107,14 +110,14 @@ -- See SchedulerIO type HasSchedulerIO r = ( HasCallStack                         , SetMember Lift (Lift IO) r-                        , Member (Logs String) r+                        , Member (Logs LogMessage) r                         , Member (Reader SchedulerVar) r)  -- | The concrete list of 'Eff'ects for this scheduler implementation. -- See HasSchedulerIO type SchedulerIO =               '[ Reader SchedulerVar-               , Logs String+               , Logs LogMessage                , Lift IO                ] @@ -125,15 +128,15 @@ -- | 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 String -> IO ()+schedule :: 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))-    logMsg (show mp ++ " main process started in thread " ++ show mt)+    logInfo (show mp ++ " main process started in thread " ++ show mt)     e-    logMsg (show mp ++ " main process returned")+    logInfo (show mp ++ " main process returned")  where   withNewSchedulerState :: (SchedulerVar -> IO a) -> IO a   withNewSchedulerState mainProcessAction = do@@ -144,7 +147,7 @@    where     myPid = 1     tearDownScheduler myTId v = do-      logChannelPutIO logC (show myTId ++ " begin scheduler tear down")+      logChannelPutIO logC (debugMessage "begin scheduler tear down")       sch <-         (atomically           (do@@ -156,12 +159,13 @@         )       logChannelPutIO         logC-        (  show myTId-        ++ " killing "-        ++ let ts = (sch ^.. threadIdTable . traversed)-           in  if length ts > 100-                 then show (length ts) ++ " threads"-                 else show ts+        (debugMessage+          (  "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@@ -177,8 +181,7 @@                   .  to Map.null           STM.check allThreadsDead         )-      logChannelPutIO logC "all threads dead"-+      logChannelPutIO logC (infoMessage "all threads dead")      killProcThread myTId _pid tid = when (myTId /= tid) (killThread tid) @@ -187,18 +190,17 @@ defaultMain :: Eff (ConsProcess SchedulerIO) () -> IO () defaultMain c = runLoggingT   (logChannelBracket 128-                     (Just "~~~~~~ main process started")-                     (Just "====== main process exited")+                     (Just (infoMessage "main process started"))                      (schedule c)   )-  (print :: String -> IO ())+  (printLogMessage :: LogMessage -> IO ())  -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output. defaultMainWithLogChannel-  :: LogChannel String -> Eff (ConsProcess SchedulerIO) () -> IO ()+  :: LogChannel LogMessage -> Eff (ConsProcess SchedulerIO) () -> IO () defaultMainWithLogChannel logC c = closeLogChannelAfter-  (Just (fromString "====== main process exited"))+  (Just (fromString "main process exited"))   logC   (schedule c logC) @@ -210,11 +212,10 @@ scheduleProcessWithShutdownAction schedulerVar pidVar procAction = do   cleanupVar <- newEmptyTMVarIO   logC       <- getLogChannelIO schedulerVar-  mTid       <- myThreadId   eeres      <- Exc.try (runProcEffects cleanupVar logC)   let eres = join eeres-  getAndExecCleanup cleanupVar eres logC mTid-  logChannelPutIO logC (show mTid ++ " <~< process cleanup finished")+  getAndExecCleanup cleanupVar eres logC+  logChannelPutIO logC =<< debugMessageIO "process cleanup finished"   return eres  where @@ -241,37 +242,44 @@             STM.putTMVar pidVar pid           )         )-      mTid <- lift myThreadId-      logMsg (show mTid ++ " >~> begin process " ++ show pid)-      procAction-  getAndExecCleanup cleanupVar eres lc mt = do+      interceptLogging+          (logMsg . over lmMessage (printf "[PID %7i] %s" (toInteger pid)))+        $ do+            logDebug "begin process"+            procAction+  getAndExecCleanup cleanupVar eres lc = do     mcleanup <- atomically (STM.tryTakeTMVar cleanupVar)     traverse_ execCleanup mcleanup    where     execCleanup ca = do       runCleanUpAction ca-      logChannelPutIO lc $ show mt ++ case eres of+      logChannelPutIO lc =<< case eres of         Left se -> case Exc.fromException se of-          Nothing -> " process caught exception: " ++ Exc.displayException se-          Just schedulerErr ->-            (case schedulerErr of-                ProcessShuttingDown  -> " process shutdown"-                ProcessExitError   m -> " process exited with error: " ++ show m-                ProcessRaisedError m -> " process raised error: " ++ show m-                _ -> " scheduler error: " ++ show schedulerErr-              )-              ++ " - full exception message: "-              ++ Exc.displayException se--        Right _ -> " process function returned"+          Nothing -> errorMessageIO+            ("process caught exception: " ++ Exc.displayException se)+          Just schedulerErr+            -> let exceptionMsg =+                     " - full exception message: " ++ Exc.displayException se+               in+                 case schedulerErr of+                   ProcessShuttingDown -> debugMessageIO "process shutdown"+                   ProcessExitError m  -> errorMessageIO+                     ("process exited with error: " ++ show m ++ exceptionMsg)+                   ProcessRaisedError m -> errorMessageIO+                     ("process raised error: " ++ show m ++ exceptionMsg)+                   _ ->+                     errorMessageIO+                       ("scheduler error: " ++ show schedulerErr ++ exceptionMsg+                       )+        Right _ -> debugMessageIO "process function returned"  -getLogChannel :: HasSchedulerIO r => Eff r (LogChannel String)+getLogChannel :: HasSchedulerIO r => Eff r (LogChannel LogMessage) getLogChannel = do   s <- getSchedulerVar   lift (getLogChannelIO s) -getLogChannelIO :: SchedulerVar -> IO (LogChannel String)+getLogChannelIO :: SchedulerVar -> IO (LogChannel LogMessage) getLogChannelIO s = view logChannel <$> readTVarIO (fromSchedulerVar s)  overProcessInfo@@ -432,7 +440,7 @@   ShutdownAction (forall a . Either SchedulerError () -> IO a)  invokeShutdownAction-  :: (HasCallStack, SetMember Lift (Lift IO) r, Member (Logs String) r)+  :: (HasCallStack, SetMember Lift (Lift IO) r, Member (Logs LogMessage) r)   => ShutdownAction   -> Either SchedulerError ()   -> Eff r a@@ -488,13 +496,16 @@                   (return . (maybe (show pid) show))      case didWork of-      Right (_pinfo, True) -> return ()-      Right (pinfo, False) ->-        logChannelPutIO lc ("queue already destroyed: " ++ show pinfo)+      Right (_pinfo, True ) -> return ()+      Right (pinfo , False) -> logChannelPutIO lc+        =<< errorMessageIO ("queue already destroyed: " ++ show pinfo)       Left (e :: Exc.SomeException) ->         getCause-          >>= logChannelPutIO lc-          .   (("failed to destroy queue: " ++ show e ++ " ") ++)+          >>= (   ( errorMessageIO+                  . (("failed to destroy queue: " ++ show e ++ " ") ++)+                  )+              >=> logChannelPutIO lc+              )   overScheduler

@@ -21,7 +21,9 @@ import           Control.Lens            hiding ( (|>)                                                 , Empty                                                 )-import           Control.Monad                  ( void )+import           Control.Monad                  ( void+                                                , (>=>)+                                                ) import           Control.Monad.IO.Class import qualified Data.Sequence                 as Seq import           Data.Sequence                  ( Seq(..) )@@ -72,7 +74,7 @@   => (l -> m ())   -> Eff (ConsProcess '[Logs l, Lift m]) a   -> m (Either String a)-scheduleIOWithLogging handleLog = scheduleIO (handleLogsWith handleLog)+scheduleIOWithLogging handleLog = scheduleIO (handleLogsLifted handleLog)  -- | Handle the 'Process' effect, as well as all lower effects using an effect handler function. --@@ -262,7 +264,7 @@ -- | The concrete list of 'Eff'ects for running this pure scheduler on @IO@ and -- with string logging. type LoggingAndIo =-              '[ Logs String+              '[ Logs LogMessage                , Lift IO                ] @@ -274,8 +276,10 @@ -- @String@ effects. defaultMain   :: HasCallStack-  => Eff '[Process '[Logs String, Lift IO], Logs String, Lift IO] ()+  => Eff '[Process '[Logs LogMessage, Lift IO], Logs LogMessage, Lift IO] ()   -> IO ()-defaultMain e = void $ runLift $ handleLogsWithLoggingTHandler-  (scheduleMonadIOEff e)-  ($! putStrLn)+defaultMain =+  void+    . runLift+    . handleLogsWithLoggingTHandler ($ printLogMessage)+    . scheduleMonadIOEff

@@ -1,337 +1,11 @@ -- | A logging effect based on 'Control.Monad.Log.MonadLog'. module Control.Eff.Log-  (-    -- * Logging Effect-    Logs(..)-  , logMsg-  , interceptLogging-  , foldLogMessages-  , module ExtLog-  , captureLogs-  , ignoreLogs-  , handleLogsWith-  , handleLogsWithLoggingTHandler-    -- * Concurrent Logging-  , LogChannel()-  , logToChannel-  , noLogger-  , forkLogger-  , filterLogChannel-  , joinLogChannel-  , killLogChannel-  , closeLogChannelAfter-  , logChannelBracket-  , logChannelPutIO-  -- ** Internals-  , JoinLogChannelException()-  , KillLogChannelException()+  ( module Control.Eff.Log.Handler+  , module Control.Eff.Log.Channel+  , module Control.Eff.Log.Message   ) where -import           Control.Concurrent-import           Control.Concurrent.STM-import           Control.DeepSeq-import           Control.Eff                   as Eff-import           Control.Eff.Extend            as Eff-import           Control.Exception              ( bracket )-import qualified Control.Exception             as Exc-import           Control.Monad                  ( void-                                                , when-                                                , unless-                                                )-import           Control.Monad.Log             as ExtLog-                                         hiding ( )-import           Control.Monad.Trans.Control-import qualified Control.Eff.Lift              as Eff-import qualified Control.Monad.Log             as Log-import           Data.Foldable                  ( traverse_ )-import           Data.Kind                      ( )-import           Data.Sequence                  ( Seq() )-import qualified Data.Sequence                 as Seq-import           Data.String-import           Data.Typeable------ | Logging effect type, parameterized by a log message type.-data Logs message a where-  LogMsg :: message -> Logs message ()---- | Log a message.-logMsg :: Member (Logs m) r => m -> Eff r ()-logMsg msg = send (LogMsg msg)---- | Change, add or remove log messages and perform arbitrary actions upon--- intercepting a log message.------ Requirements:------   * All log meta data for typical prod code can be added without---     changing much of the code------   * Add timestamp to a log messages of a sub-computation.------   * Write some messages to a file.------   * Log something extra, e.g. runtime memory usage in load tests------ Approach: Install a callback that sneaks into to log message--- sending/receiving, to intercept the messages and execute some code and then--- return a new message.-interceptLogging-  :: forall r m a . Member (Logs m) r => (m -> Eff r ()) -> Eff r a -> Eff r a-interceptLogging interceptor = interpose return go- where-  go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y-  go (LogMsg m) k = do-    interceptor m-    k ()---- | Intercept logging to change, add or remove log messages.------ This is without side effects, hence faster than 'interceptLogging'.-foldLogMessages-  :: forall r m a f-   . (Foldable f, Member (Logs m) r)-  => (m -> f m)-  -> Eff r a-  -> Eff r a-foldLogMessages interceptor = interpose return go- where-  go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y-  go (LogMsg m) k = do-    traverse_ logMsg (interceptor m)-    k ()---- | Capture all log messages in a 'Seq' (strict).-captureLogs-  :: NFData message => Eff (Logs message ': r) a -> Eff r (a, Seq message)-captureLogs = Eff.handle_relay_s Seq.empty-                                 (\logs result -> return (result, logs))-                                 handleLogs- where-  handleLogs-    :: NFData message-    => Seq message-    -> Logs message x-    -> (Seq message -> Arr r x y)-    -> Eff r y-  handleLogs !logs (LogMsg !m) k = k (force (logs Seq.:|> m)) ()---- | Throw away all log messages.-ignoreLogs :: forall message r a . Eff (Logs message ': r) a -> Eff r a-ignoreLogs = Eff.handle_relay return handleLogs- where-  handleLogs :: Logs m x -> Arr r x y -> Eff r y-  handleLogs (LogMsg _) k = k ()---- | Handle the 'Logs' effect with a monadic call back function (strict).-handleLogsWith-  :: forall m r message a-   . (NFData message, Monad m, SetMember Eff.Lift (Eff.Lift m) r)-  => (message -> m ())-  -> Eff (Logs message ': r) a-  -> Eff r a-handleLogsWith logMessageHandler = Eff.handle_relay return go- where-  go :: Logs message b -> (b -> Eff r c) -> Eff r c-  go (LogMsg m) k = do-    res <- Eff.lift (logMessageHandler (force m))-    k res---- | Handle the 'Logs' effect using 'Log.LoggingT' 'Log.Handler's.-handleLogsWithLoggingTHandler-  :: forall m r message a-   . (Monad m, SetMember Eff.Lift (Eff.Lift m) r)-  => Eff (Logs message ': r) a-  -> (forall b . (Log.Handler m message -> m b) -> m b)-  -> Eff r a-handleLogsWithLoggingTHandler actionThatLogs foldHandler = Eff.handle_relay-  return-  go-  actionThatLogs- where-  go :: Logs message b -> (b -> Eff r c) -> Eff r c-  go (LogMsg m) k = Eff.lift (foldHandler (\doLog -> doLog m)) >>= k---- | A log channel processes logs from the 'Logs' effect by en-queuing them in a--- shared queue read from a seperate processes. A channel can contain log--- message filters.-data LogChannel message =-   FilteredLogChannel (message -> Bool) (LogChannel message)-   -- ^ filter log messages- | DiscardLogs-   -- ^ discard all log messages- | ConcurrentLogChannel-   { fromLogChannel :: TBQueue message-   , _logChannelThread :: ThreadId-   }-   -- ^ send all log messages to a log process---- | Send the log messages to a 'LogChannel'.-logToChannel-  :: forall r message a-   . (SetMember Eff.Lift (Eff.Lift IO) r)-  => LogChannel message-  -> Eff (Logs message ': r) a-  -> Eff r a-logToChannel logChan actionThatLogs = handleLogsWithLoggingTHandler-  actionThatLogs-  (\withHandler -> withHandler (logChannelPutIO logChan))---- | Enqueue a log message into a log channel-logChannelPutIO :: LogChannel message -> message -> IO ()-logChannelPutIO DiscardLogs               _ = return ()-logChannelPutIO (FilteredLogChannel f lc) m = when (f m) (logChannelPutIO lc m)-logChannelPutIO c                         m = atomically $ do-  dropMessage <- isFullTBQueue (fromLogChannel c)-  unless dropMessage (writeTBQueue (fromLogChannel c) m)---- | Create a 'LogChannel' that will discard all messages sent--- via 'forwardLogstochannel' or 'logChannelPutIO'.-noLogger :: LogChannel message-noLogger = DiscardLogs---- | Fork a new process, that applies a monadic action to all log messages sent--- via 'logToChannel' or 'logChannelPutIO'.-forkLogger-  :: forall message-   . (Typeable message, Show message)-  => Int -- ^ Size of the log message input queue. If the queue is full, message-        -- are dropped silently.-  -> (message -> IO ()) -- ^ An IO action to log the messages-  -> Maybe message -- ^ Optional __first__ message to log-  -> IO (LogChannel message)-forkLogger queueLen handle mFirstMsg = do-  msgQ <- atomically-    (do-      tq <- newTBQueue (fromIntegral @Int queueLen)-      mapM_ (writeTBQueue tq) mFirstMsg-      return tq-    )-  thread <- forkFinally (logLoop msgQ) (writeLastLogs msgQ)-  return (ConcurrentLogChannel msgQ thread)- where-  writeLastLogs :: TBQueue message -> Either Exc.SomeException () -> IO ()-  writeLastLogs tq ee = do-    logMessages <- atomically $ flushTBQueue tq-    case ee of-      Right _  -> return ()-      Left  se -> case Exc.fromException se of-        Just (JoinLogChannelException mCloseMsg) -> do-          traverse_ handle logMessages-          traverse_ handle mCloseMsg-        Nothing -> case Exc.fromException se of-          Just (KillLogChannelException mCloseMsg) ->-            traverse_ handle mCloseMsg-          Nothing -> mapM_ handle logMessages--  logLoop :: TBQueue message -> IO ()-  logLoop tq = do-    m <- atomically $ readTBQueue tq-    handle m-    logLoop tq---- | Filter logs sent to a 'LogChannel' using a predicate.-filterLogChannel-  :: (message -> Bool) -> LogChannel message -> LogChannel message-filterLogChannel = FilteredLogChannel---- | Run an action and close a 'LogChannel' created by 'noLogger', 'forkLogger'--- or 'filterLogChannel' afterwards using 'joinLogChannel'. If a--- 'Exc.SomeException' was thrown, the log channel is killed with--- 'killLogChannel', and the exception is re-thrown.-closeLogChannelAfter-  :: (Show message, Typeable message, IsString message)-  => Maybe message-  -> LogChannel message-  -> IO a-  -> IO a-closeLogChannelAfter mGoodbye logC ioAction = do-  res <- closeLogAndRethrow `Exc.handle` ioAction-  closeLogSuccess-  return res- where-  closeLogAndRethrow :: Exc.SomeException -> IO a-  closeLogAndRethrow se = do-    let closeMsg = Just (fromString (Exc.displayException se))-    void $ Exc.try @Exc.SomeException $ killLogChannel closeMsg logC-    Exc.throw se--  closeLogSuccess :: IO ()-  closeLogSuccess = joinLogChannel mGoodbye logC---- | Close a log channel created by e.g. 'forkLogger'. Message already enqueue--- are handled, as well as an optional final message. Subsequent log message--- will not be handled anymore. If the log channel must be closed immediately,--- use 'killLogChannel' instead.-joinLogChannel-  :: (Show message, Typeable message)-  => Maybe message-  -> LogChannel message-  -> IO ()-joinLogChannel _closeLogMessage DiscardLogs = return ()-joinLogChannel Nothing (FilteredLogChannel _f lc) = joinLogChannel Nothing lc-joinLogChannel (Just closeLogMessage) (FilteredLogChannel f lc) =-  if f closeLogMessage-    then joinLogChannel (Just closeLogMessage) lc-    else joinLogChannel Nothing lc-joinLogChannel closeLogMessage (ConcurrentLogChannel _tq thread) =-  throwTo thread (JoinLogChannelException closeLogMessage)---- | Close a log channel quickly, without logging messages already in the queue.--- Subsequent logging requests will not be handled anymore. If the log channel--- must be closed without loosing any messages, use 'joinLogChannel' instead.-killLogChannel-  :: (Show message, Typeable message)-  => Maybe message-  -> LogChannel message-  -> IO ()-killLogChannel _closeLogMessage DiscardLogs = return ()-killLogChannel Nothing (FilteredLogChannel _f lc) = killLogChannel Nothing lc-killLogChannel (Just closeLogMessage) (FilteredLogChannel f lc) =-  if f closeLogMessage-    then killLogChannel (Just closeLogMessage) lc-    else killLogChannel Nothing lc-killLogChannel closeLogMessage (ConcurrentLogChannel _tq thread) =-  throwTo thread (KillLogChannelException closeLogMessage)---- | Internal exception to shutdown a 'LogChannel' process created by--- 'forkLogger'. This exception is handled such that all message already--- en-queued are handled and then an optional final message is written.-newtype JoinLogChannelException m = JoinLogChannelException (Maybe m)-  deriving (Show, Typeable)--instance (Typeable m, Show m) => Exc.Exception (JoinLogChannelException m)---- | Internal exception to **immediately** shutdown a 'LogChannel' process--- created by 'forkLogger', other than 'JoinLogChannelException' the message queue--- will not be flushed, not further messages will be logged, except for the--- optional final message.-newtype KillLogChannelException m = KillLogChannelException (Maybe m)-  deriving (Show, Typeable)--instance (Typeable m, Show m) => Exc.Exception (KillLogChannelException m)---- | Wrap 'LogChannel' creation and destruction around a monad action in--- 'bracket'y manner. This function uses 'joinLogChannel', so en-queued messages--- are flushed on exit. The resulting action is a 'LoggingT' action, which--- is essentially a reader for a log handler function in 'IO'.-logChannelBracket-  :: (Show message, Typeable message)-  => Int -- ^ Size of the log message input queue. If the queue is full, message-        -- are dropped silently.-  -> Maybe message -- ^ Optional __first__ message to log-  -> Maybe message -- ^ Optional __last__ message to log-  -> (LogChannel message -> IO a) -- ^ An IO action that will use the-                                -- 'LogChannel', after the action returns (even-                                -- because of an exception) the log channel is-                                -- destroyed.-  -> LoggingT message IO a-logChannelBracket queueLen mWelcome mGoodbye f = control-  (\runInIO -> do-    let logHandler = void . runInIO . logMessage-    bracket (forkLogger queueLen logHandler mWelcome)-            (joinLogChannel mGoodbye)-            f-  )+import           Control.Eff.Log.Handler+import           Control.Eff.Log.Channel+import           Control.Eff.Log.Message

@@ -0,0 +1,193 @@+-- | Concurrent Logging+module Control.Eff.Log.Channel+  ( LogChannel()+  , logToChannel+  , noLogger+  , forkLogger+  , filterLogChannel+  , joinLogChannel+  , killLogChannel+  , closeLogChannelAfter+  , logChannelBracket+  , logChannelPutIO+  , JoinLogChannelException()+  , KillLogChannelException()+  )+where++import           Control.Concurrent+import           Control.Concurrent.STM+import           Control.Eff                   as Eff+import           Control.Exception              ( bracket )+import qualified Control.Exception             as Exc+import           Control.Monad                  ( void+                                                , when+                                                , unless+                                                )+import           Control.Monad.Log             as ExtLog+                                         hiding ( )+import           Control.Monad.Trans.Control+import           Control.Eff.Log.Handler+import qualified Control.Eff.Lift              as Eff+import           Data.Foldable                  ( traverse_ )+import           Data.Kind                      ( )+import           Data.String+import           Data.Typeable++-- | A log channel processes logs from the 'Logs' effect by en-queuing them in a+-- shared queue read from a seperate processes. A channel can contain log+-- message filters.+data LogChannel message =+   FilteredLogChannel (message -> Bool) (LogChannel message)+   -- ^ filter log messages+ | DiscardLogs+   -- ^ discard all log messages+ | ConcurrentLogChannel+   { fromLogChannel :: TBQueue message+   , _logChannelThread :: ThreadId+   }+   -- ^ send all log messages to a log process++-- | Send the log messages to a 'LogChannel'.+logToChannel+  :: forall r message a+   . (SetMember Eff.Lift (Eff.Lift IO) r)+  => LogChannel message+  -> Eff (Logs message ': r) a+  -> Eff r a+logToChannel logChan =+  handleLogsWithLoggingTHandler ($ logChannelPutIO logChan)++-- | Enqueue a log message into a log channel+logChannelPutIO :: LogChannel message -> message -> IO ()+logChannelPutIO DiscardLogs               _ = return ()+logChannelPutIO (FilteredLogChannel f lc) m = when (f m) (logChannelPutIO lc m)+logChannelPutIO c                         m = atomically $ do+  dropMessage <- isFullTBQueue (fromLogChannel c)+  unless dropMessage (writeTBQueue (fromLogChannel c) m)++-- | Create a 'LogChannel' that will discard all messages sent+-- via 'forwardLogstochannel' or 'logChannelPutIO'.+noLogger :: LogChannel message+noLogger = DiscardLogs++-- | Fork a new process, that applies a monadic action to all log messages sent+-- via 'logToChannel' or 'logChannelPutIO'.+forkLogger+  :: forall message+   . (Typeable message)+  => Int -- ^ Size of the log message input queue. If the queue is full, message+        -- are dropped silently.+  -> (message -> IO ()) -- ^ An IO action to log the messages+  -> Maybe message -- ^ Optional __first__ message to log+  -> IO (LogChannel message)+forkLogger queueLen handle mFirstMsg = do+  msgQ <- atomically+    (do+      tq <- newTBQueue (fromIntegral @Int queueLen)+      mapM_ (writeTBQueue tq) mFirstMsg+      return tq+    )+  thread <- forkFinally (logLoop msgQ) (writeLastLogs msgQ)+  return (ConcurrentLogChannel msgQ thread)+ where+  writeLastLogs :: TBQueue message -> Either Exc.SomeException () -> IO ()+  writeLastLogs tq ee = do+    logMessages <- atomically $ flushTBQueue tq+    case ee of+      Right _  -> return ()+      Left  se -> case Exc.fromException se of+        Just JoinLogChannelException -> traverse_ handle logMessages+        Nothing                      -> case Exc.fromException se of+          Just KillLogChannelException -> return ()+          Nothing                      -> mapM_ handle logMessages++  logLoop :: TBQueue message -> IO ()+  logLoop tq = do+    m <- atomically $ readTBQueue tq+    handle m+    logLoop tq++-- | Filter logs sent to a 'LogChannel' using a predicate.+filterLogChannel+  :: (message -> Bool) -> LogChannel message -> LogChannel message+filterLogChannel = FilteredLogChannel++-- | Run an action and close a 'LogChannel' created by 'noLogger', 'forkLogger'+-- or 'filterLogChannel' afterwards using 'joinLogChannel'. If a+-- 'Exc.SomeException' was thrown, the log channel is killed with+-- 'killLogChannel', and the exception is re-thrown.+closeLogChannelAfter+  :: (Typeable message, IsString message)+  => Maybe message+  -> LogChannel message+  -> IO a+  -> IO a+closeLogChannelAfter mGoodbye logC ioAction = do+  res <- closeLogAndRethrow `Exc.handle` ioAction+  closeLogSuccess+  return res+ where+  closeLogAndRethrow :: Exc.SomeException -> IO a+  closeLogAndRethrow se = do+    void $ Exc.try @Exc.SomeException $ killLogChannel logC+    Exc.throw se++  closeLogSuccess :: IO ()+  closeLogSuccess = joinLogChannel logC++-- | Close a log channel created by e.g. 'forkLogger'. Message already enqueue+-- are handled. Subsequent log message+-- will not be handled anymore. If the log channel must be closed immediately,+-- use 'killLogChannel' instead.+joinLogChannel :: (Typeable message) => LogChannel message -> IO ()+joinLogChannel DiscardLogs                = return ()+joinLogChannel (FilteredLogChannel _f lc) = joinLogChannel lc+joinLogChannel (ConcurrentLogChannel _tq thread) =+  throwTo thread JoinLogChannelException++-- | Close a log channel quickly, without logging messages already in the queue.+-- Subsequent logging requests will not be handled anymore. If the log channel+-- must be closed without loosing any messages, use 'joinLogChannel' instead.+killLogChannel :: (Typeable message) => LogChannel message -> IO ()+killLogChannel DiscardLogs                = return ()+killLogChannel (FilteredLogChannel _f lc) = killLogChannel lc+killLogChannel (ConcurrentLogChannel _tq thread) =+  throwTo thread KillLogChannelException++-- | Internal exception to shutdown a 'LogChannel' process created by+-- 'forkLogger'. This exception is handled such that all message already+-- en-queued are handled and then an optional final message is written.+data JoinLogChannelException = JoinLogChannelException+  deriving (Show, Typeable)++instance Exc.Exception JoinLogChannelException++-- | Internal exception to **immediately** shutdown a 'LogChannel' process+-- created by 'forkLogger', other than 'JoinLogChannelException' the message queue+-- will not be flushed, not further messages will be logged, except for the+-- optional final message.+data KillLogChannelException = KillLogChannelException+  deriving (Show, Typeable)++instance Exc.Exception KillLogChannelException++-- | Wrap 'LogChannel' creation and destruction around a monad action in+-- 'bracket'y manner. This function uses 'joinLogChannel', so en-queued messages+-- are flushed on exit. The resulting action is a 'LoggingT' action, which+-- is essentially a reader for a log handler function in 'IO'.+logChannelBracket+  :: (Typeable message)+  => Int -- ^ Size of the log message input queue. If the queue is full, message+        -- are dropped silently.+  -> Maybe message -- ^ Optional __first__ message to log+  -> (LogChannel message -> IO a) -- ^ An IO action that will use the+                                -- 'LogChannel', after the action returns (even+                                -- because of an exception) the log channel is+                                -- destroyed.+  -> LoggingT message IO a+logChannelBracket queueLen mWelcome f = control+  (\runInIO -> do+    let logHandler = void . runInIO . logMessage+    bracket (forkLogger queueLen logHandler mWelcome) joinLogChannel f+  )

@@ -0,0 +1,137 @@+-- | A logging effect based on 'Control.Monad.Log.MonadLog'.+module Control.Eff.Log.Handler+  (+    -- * Logging Effect+    Logs(..)+  , logMsg+  , interceptLogging+  , foldLogMessages+  , relogAsString+  , captureLogs+  , ignoreLogs+  , handleLogsWith+  , handleLogsLifted+  , handleLogsWithLoggingTHandler+  )+where++import           Control.DeepSeq+import           Control.Eff                   as Eff+import           Control.Eff.Extend            as Eff+import qualified Control.Eff.Lift              as Eff+import qualified Control.Monad.Log             as Log+import           Data.Foldable                  ( traverse_ )+import           Data.Kind                      ( )+import           Data.Sequence                  ( Seq() )+import qualified Data.Sequence                 as Seq++-- | Logging effect type, parameterized by a log message type.+data Logs message a where+  LogMsg :: message -> Logs message ()++-- | Log a message.+logMsg :: Member (Logs m) r => m -> Eff r ()+logMsg = send . LogMsg++-- | Change, add or remove log messages and perform arbitrary actions upon+-- intercepting a log message.+--+-- Requirements:+--+--   * All log meta data for typical prod code can be added without+--     changing much of the code+--+--   * Add timestamp to a log messages of a sub-computation.+--+--   * Write some messages to a file.+--+--   * Log something extra, e.g. runtime memory usage in load tests+--+-- Approach: Install a callback that sneaks into to log message+-- sending/receiving, to intercept the messages and execute some code and then+-- return a new message.+interceptLogging+  :: forall r m a . Member (Logs m) r => (m -> Eff r ()) -> Eff r a -> Eff r a+interceptLogging interceptor = interpose return go+ where+  go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y+  go (LogMsg m) k = do+    interceptor m+    k ()++-- | Intercept logging to change, add or remove log messages.+--+-- This is without side effects, hence faster than 'interceptLogging'.+foldLogMessages+  :: forall r m a f+   . (Foldable f, Member (Logs m) r)+  => (m -> f m)+  -> Eff r a+  -> Eff r a+foldLogMessages interceptor = interpose return go+ where+  go :: Member (Logs m) r => Logs m x -> (Arr r x y) -> Eff r y+  go (LogMsg m) k = do+    traverse_ logMsg (interceptor m)+    k ()++-- | Capture all log messages in a 'Seq' (strict).+captureLogs+  :: NFData message => Eff (Logs message ': r) a -> Eff r (a, Seq message)+captureLogs = Eff.handle_relay_s Seq.empty+                                 (\logs result -> return (result, logs))+                                 handleLogs+ where+  handleLogs+    :: NFData message+    => Seq message+    -> Logs message x+    -> (Seq message -> Arr r x y)+    -> Eff r y+  handleLogs !logs (LogMsg !m) k = k (force (logs Seq.:|> m)) ()++-- | Throw away all log messages.+ignoreLogs :: forall message r a . Eff (Logs message ': r) a -> Eff r a+ignoreLogs = Eff.handle_relay return handleLogs+ where+  handleLogs :: Logs m x -> Arr r x y -> Eff r y+  handleLogs (LogMsg _) k = k ()++-- | Handle a 'Logs' effect with a message that has a 'Show' instance by+-- **re-logging** each message applied to 'show'.+relogAsString+  :: forall m e a+   . (Show m, Member (Logs String) e)+  => Eff (Logs m ': e) a+  -> Eff e a+relogAsString = handleLogsWith (logMsg . show)++-- | Apply a function that returns an effect to each log message.+handleLogsWith+  :: forall message e a+   . (message -> Eff e ())+  -> Eff (Logs message ': e) a+  -> Eff e a+handleLogsWith h = handle_relay return $ \(LogMsg m) k -> h m >>= k++-- | Handle the 'Logs' effect with a monadic call back function (strict).+handleLogsLifted+  :: forall m r message a+   . (NFData message, Monad m, SetMember Eff.Lift (Eff.Lift m) r)+  => (message -> m ())+  -> Eff (Logs message ': r) a+  -> Eff r a+handleLogsLifted logMessageHandler = handleLogsWith go+ where+  go :: message -> Eff r ()+  go m = Eff.lift (logMessageHandler (force m))++-- | Handle the 'Logs' effect using 'Log.LoggingT' 'Log.Handler's.+handleLogsWithLoggingTHandler+  :: forall m r message a+   . (Monad m, SetMember Eff.Lift (Eff.Lift m) r)+  => (forall b . (Log.Handler m message -> m b) -> m b)+  -> Eff (Logs message ': r) a+  -> Eff r a+handleLogsWithLoggingTHandler foldHandler =+  handleLogsWith (Eff.lift . foldHandler . flip ($))

@@ -0,0 +1,421 @@+-- | An RFC 5434 inspired log message and convenience functions for+-- logging them.+module Control.Eff.Log.Message+  ( LogMessage(..)+  , renderRFC5424+  , printLogMessage+  , relogAsDebugMessages+  , logWithSeverity+  , logEmergency+  , logAlert+  , logCritical+  , logError+  , logWarning+  , logNotice+  , logInfo+  , logDebug+  , errorMessage+  , infoMessage+  , debugMessage+  , errorMessageIO+  , infoMessageIO+  , debugMessageIO+  , Severity(fromSeverity)+  , emergencySeverity+  , alertSeverity+  , criticalSeverity+  , errorSeverity+  , warningSeverity+  , noticeSeverity+  , informationalSeverity+  , debugSeverity+  , Facility(fromFacility)+  , kernelMessages+  , userLevelMessages+  , mailSystem+  , systemDaemons+  , securityAuthorizationMessages4+  , linePrinterSubsystem+  , networkNewsSubsystem+  , uucpSubsystem+  , clockDaemon+  , securityAuthorizationMessages10+  , ftpDaemon+  , ntpSubsystem+  , logAuditFacility+  , logAlertFacility+  , clockDaemon2+  , local0+  , local1+  , local2+  , local3+  , local4+  , local5+  , local6+  , local7+  , lmFacility+  , lmSeverity+  , lmTimestamp+  , lmHostname+  , lmAppname+  , lmProcessId+  , lmMessageId+  , lmStructuredData+  , lmSrcLoc+  , lmThreadId+  , lmMessage+  , setCallStack+  , StructuredDataElement(..)+  , sdElementId+  , sdElementParameters+  )+where++import           Data.Time.Clock+import           Data.Time.Format+import           Control.Lens+import           Control.Eff+import           Control.Eff.Log.Handler+import           GHC.Stack+import           Data.Default+import           Control.DeepSeq+import           Control.Monad.IO.Class+import           Data.Maybe+import           Data.String+import           Control.Concurrent+import           GHC.Generics+import           Text.Printf+import           Control.Monad                  ( (>=>) )++-- | A message data type inspired by the RFC-5424 Syslog Protocol+data LogMessage =+  LogMessage { _lmFacility :: Facility+             , _lmSeverity :: Severity+             , _lmTimestamp :: Maybe UTCTime+             , _lmHostname :: Maybe String+             , _lmAppname :: Maybe String+             , _lmProcessId :: Maybe String+             , _lmMessageId :: Maybe String+             , _lmStructuredData :: [StructuredDataElement]+             , _lmThreadId :: Maybe ThreadId+             , _lmSrcLoc :: Maybe SrcLoc+             , _lmMessage :: String}+  deriving (Eq, Generic)++showLmMessage :: LogMessage -> [String]+showLmMessage (LogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =+  if null msg+    then []+    else+      maybe "" (printf "[%s]" . show) ti+      : msg+      : maybe [] (pure . prettySrcLoc) loc+++-- | Render a 'LogMessage' human readable.+renderLogMessage :: LogMessage -> String+renderLogMessage l@(LogMessage _f s ts hn an pid mi sd _ _ _) =+  unwords $ filter+    (not . null)+    ( maybe+        ""+        (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")))+        ts+    : fromMaybe "" hn+    : show s+    : fromMaybe "" an+    : fromMaybe "" pid+    : fromMaybe "" mi+    : (if null sd then "" else show sd)+    : showLmMessage l+    )++-- | Render a 'LogMessage' according to the rules in the given RFC, except for+-- the rules concerning unicode and ascii+renderRFC5424 :: LogMessage -> String+renderRFC5424 l@(LogMessage f s ts hn an pid mi sd _ _ _) = unwords+  ( ("<" ++ show (fromSeverity s + fromFacility f * 8) ++ ">" ++ "1")+  : maybe+      "-"+      (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")))+      ts+  : fromMaybe "-" hn+  : fromMaybe "-" an+  : fromMaybe "-" pid+  : fromMaybe "-" mi+  : (if null sd then "-" else show sd)+  : showLmMessage l+  )+++instance NFData LogMessage++-- | RFC-5424 defines how structured data can be included in a log message.+data StructuredDataElement =+  SdElement { _sdElementId :: String+            , _sdElementParameters :: [SdParameter]}+  deriving (Eq, Ord, Generic)++instance Show StructuredDataElement where+  show (SdElement sdid params) =+    "[" ++ sdName sdid ++ if null params then "" else " " ++ unwords (show <$> params) ++ "]"++instance NFData StructuredDataElement++-- | Component of a 'StructuredDataElement'+data SdParameter =+  SdParameter String String+  deriving (Eq, Ord, Generic)++instance Show SdParameter where+  show (SdParameter k v) = sdName k ++ "=\"" ++ sdParamValue v ++ "\""++sdName :: String -> String+sdName = take 32 . filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"')++sdParamValue :: String -> String+sdParamValue e = e >>= \case+  '"'  -> "\\\""+  '\\' -> "\\\\"+  ']'  -> "\\]"+  x    -> [x]++instance NFData SdParameter++-- | An rfc 5424 severity+newtype Severity =+  Severity {fromSeverity :: Int}+  deriving (Eq, Ord, Generic, NFData)++instance Show Severity where+  show (Severity 1)             = "ALERT    "+  show (Severity 2)             = "CRITICAL "+  show (Severity 3)             = "ERROR    "+  show (Severity 4)             = "WARNING  "+  show (Severity 5)             = "NOTICE   "+  show (Severity 6)             = "INFO     "+  show (Severity x) |  x <= 0   = "EMERGENCY"+                    | otherwise = "DEBUG    "++-- | An rfc 5424 facility+newtype Facility = Facility {fromFacility :: Int}+  deriving (Eq, Ord, Show, Generic, NFData)+++makeLenses ''StructuredDataElement+makeLenses ''LogMessage++-- | Put the source location of the given callstack in 'lmSrcLoc'+setCallStack :: CallStack -> LogMessage -> LogMessage+setCallStack cs m = case getCallStack cs of+  []              -> m+  (_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc++instance Default LogMessage where+  def = setCallStack callStack (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++-- | An IO action that sets the current UTC time (see 'enableLogMessageTimestamps')+-- in 'lmTimestamp'.+setLogMessageTimestamp :: MonadIO m => LogMessage -> m LogMessage+setLogMessageTimestamp m = do+  now <- liftIO getCurrentTime+  return (m & lmTimestamp ?~ now)++-- | An IO action appends the the 'ThreadId' of the calling process (see 'myThreadId')+-- to 'lmMessage'.+setLogMessageThreadId :: MonadIO m => LogMessage -> m LogMessage+setLogMessageThreadId m = do+  t <- liftIO myThreadId+  return (m & lmThreadId ?~ t)++-- | 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++-- | Log a 'String' as 'LogMessage' with a given 'Severity'.+logWithSeverity :: Member (Logs LogMessage) e => Severity -> String -> Eff e ()+logWithSeverity s =+  withFrozenCallStack+    . 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++-- | Log a message with 'alertSeverity'.+logAlert :: 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++-- | Log a 'errorSeverity' message.+logError :: 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++-- | Log a 'noticeSeverity' message.+logNotice :: 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++-- | Log a 'debugSeverity' message.+logDebug :: Member (Logs LogMessage) e => String -> Eff e ()+logDebug = withFrozenCallStack . logWithSeverity debugSeverity++-- | Construct a 'LogMessage' with 'errorSeverity'+errorMessage :: String -> LogMessage+errorMessage m = withFrozenCallStack+  (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack)++-- | Construct a 'LogMessage' with 'informationalSeverity'+infoMessage :: String -> LogMessage+infoMessage m = withFrozenCallStack+  (  def+  &  lmSeverity+  .~ informationalSeverity+  &  lmMessage+  .~ m+  &  setCallStack callStack+  )++-- | Construct a 'LogMessage' with 'debugSeverity'+debugMessage :: String -> LogMessage+debugMessage m = withFrozenCallStack+  (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack)++-- | Construct a 'LogMessage' with 'errorSeverity'+errorMessageIO :: MonadIO m => String -> m LogMessage+errorMessageIO =+  (setLogMessageThreadId >=> setLogMessageTimestamp) . errorMessage+-- | Construct a 'LogMessage' with 'informationalSeverity'+infoMessageIO :: MonadIO m => String -> m LogMessage+infoMessageIO =+  (setLogMessageThreadId >=> setLogMessageTimestamp) . infoMessage+-- | Construct a 'LogMessage' with 'debugSeverity'+debugMessageIO :: MonadIO m => String -> m LogMessage+debugMessageIO =+  (setLogMessageThreadId >=> setLogMessageTimestamp) . debugMessage+++emergencySeverity :: Severity+emergencySeverity = Severity 0++alertSeverity :: Severity+alertSeverity = Severity 1++criticalSeverity :: Severity+criticalSeverity = Severity 2++errorSeverity :: Severity+errorSeverity = Severity 3++warningSeverity :: Severity+warningSeverity = Severity 4++noticeSeverity :: Severity+noticeSeverity = Severity 5++informationalSeverity :: Severity+informationalSeverity = Severity 6++debugSeverity :: Severity+debugSeverity = Severity 7++instance Default Severity where+  def = debugSeverity++kernelMessages :: Facility+kernelMessages = Facility 0++userLevelMessages :: Facility+userLevelMessages = Facility 1++mailSystem :: Facility+mailSystem = Facility 2++systemDaemons :: Facility+systemDaemons = Facility 3++securityAuthorizationMessages4 :: Facility+securityAuthorizationMessages4 = Facility 4++linePrinterSubsystem :: Facility+linePrinterSubsystem = Facility 6++networkNewsSubsystem :: Facility+networkNewsSubsystem = Facility 7++uucpSubsystem :: Facility+uucpSubsystem = Facility 8++clockDaemon :: Facility+clockDaemon = Facility 9++securityAuthorizationMessages10 :: Facility+securityAuthorizationMessages10 = Facility 10++ftpDaemon :: Facility+ftpDaemon = Facility 11++ntpSubsystem :: Facility+ntpSubsystem = Facility 12++logAuditFacility :: Facility+logAuditFacility = Facility 13++logAlertFacility :: Facility+logAlertFacility = Facility 14++clockDaemon2 :: Facility+clockDaemon2 = Facility 15++local0 :: Facility+local0 = Facility 16++local1 :: Facility+local1 = Facility 17++local2 :: Facility+local2 = Facility 18++local3 :: Facility+local3 = Facility 19++local4 :: Facility+local4 = Facility 20++local5 :: Facility+local5 = Facility 21++local6 :: Facility+local6 = Facility 22++local7 :: Facility+local7 = Facility 23++instance Default Facility where+  def = local7

@@ -1,56 +0,0 @@-module Control.Eff.Log.MessageFactory-  ( mkLogMsg-  , MessageFactory()-  , MessageFactoryReader-  , withLogMessageFactory-  , composeMessageFactories-  , localMessageFactory-  )-where--import           Control.Eff-import           Control.Eff.Log         hiding ( Severity )-import           Control.Eff.Reader.Strict-import           Control.Eff.Lift-import           Control.Monad.IO.Class-import           Data.Default--newtype MessageFactory m =-  MessageFactory { runMessageFactory :: IO m}--type MessageFactoryReader m = Reader (MessageFactory m)--mkLogMsg-  :: forall m io e-   . ( Member (Logs m) e-     , MonadIO io-     , SetMember Lift (Lift io) e-     , Member (MessageFactoryReader m) e-     )-  => (m -> m)-  -> Eff e ()-mkLogMsg f = ask >>= lift . liftIO . runMessageFactory >>= logMsg . f--localMessageFactory-  :: forall m e a-   . (Member (MessageFactoryReader m) e)-  => IO m-  -> Eff e a-  -> Eff e a-localMessageFactory = local . const . MessageFactory--composeMessageFactories-  :: forall m e a-   . (Member (MessageFactoryReader m) e)-  => (m -> IO m)-  -> Eff e a-  -> Eff e a-composeMessageFactories f2 =-  local (\(MessageFactory f1) -> MessageFactory (f1 >>= f2))--withLogMessageFactory-  :: forall m io e a-   . (Member (Logs m) e, Default m, MonadIO io, SetMember Lift (Lift io) e)-  => Eff (MessageFactoryReader m ': e) a-  -> Eff e a-withLogMessageFactory = runReader (MessageFactory (return def))

@@ -1,249 +0,0 @@--- | An RFC 5434 inspired log message and convenience functions for--- logging them. TODO document-module Control.Eff.Log.Syslog-  ( Severity(fromSeverity)-  , emergencySeverity-  , alertSeverity-  , criticalSeverity-  , errorSeverity-  , warningSeverity-  , noticeSeverity-  , informationalSeverity-  , debugSeverity-  , Facility(fromFacility)-  , kernelMessages-  , userLevelMessages-  , mailSystem-  , systemDaemons-  , securityAuthorizationMessages4-  , linePrinterSubsystem-  , networkNewsSubsystem-  , uucpSubsystem-  , clockDaemon-  , securityAuthorizationMessages10-  , ftpDaemon-  , ntpSubsystem-  , logAuditFacility-  , logAlertFacility-  , clockDaemon2-  , local0-  , local1-  , local2-  , local3-  , local4-  , local5-  , local6-  , local7-  , LogMessage(..)-  , lmFacility-  , lmSeverity-  , lmTimestamp-  , lmHostname-  , lmAppname-  , lmProcessId-  , lmMessageId-  , lmStructuredData-  , lmSrcLoc-  , lmMessage-  , StructuredDataElement(..)-  , sdElementId-  , sdElementParameters-  , addSyslogTimestamps-  , syslogMsg-  , withSyslog-  )-where--import           Data.Time.Clock-import           Data.Time.Format-import           Control.Lens-import           Control.Eff-import           Control.Eff.Lift-import           Control.Eff.Log         hiding ( Severity )-import           GHC.Stack-import           Data.Default-import           Control.Eff.Log.MessageFactory-import           Control.DeepSeq-import           Control.Monad.IO.Class-import           Data.Maybe-import           GHC.Generics--data LogMessage =-  LogMessage { _lmFacility :: Facility-             , _lmSeverity :: Severity-             , _lmTimestamp :: Maybe UTCTime-             , _lmHostname :: Maybe String-             , _lmAppname :: Maybe String-             , _lmProcessId :: Maybe String-             , _lmMessageId :: Maybe String-             , _lmStructuredData :: [StructuredDataElement]-             , _lmSrcLoc :: Maybe SrcLoc-             , _lmMessage :: String}-  deriving (Eq, Generic)--instance Show LogMessage where-  show (LogMessage f s ts hn an pid mi sd loc msg) =-    unwords-      ( ("<" ++ show (fromSeverity s + fromFacility f * 8) ++ ">" ++ "1")-     : maybe "-" (formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S"))) ts-     : fromMaybe "-" hn-     : fromMaybe "-" an-     : fromMaybe "-" pid-     : fromMaybe "-" mi-     : (if null sd then "-" else show sd)-     : (if null msg then [] else msg : maybe [] (pure . prettySrcLoc) loc))--instance NFData LogMessage--data StructuredDataElement =-  StructuredDataElement {_sdElementId :: String-                        ,_sdElementParameters :: [(String, Maybe String)]}-  deriving (Eq, Ord, Show, Generic)--instance NFData StructuredDataElement--instance Default LogMessage where-  def = LogMessage local7 debugSeverity def def def def def def def ""---- | An rfc 5424 severity-newtype Severity = Severity {fromSeverity :: Int}-  deriving (Eq, Ord, Show, Generic, NFData)--emergencySeverity :: Severity-emergencySeverity = Severity 0--alertSeverity :: Severity-alertSeverity = Severity 1--criticalSeverity :: Severity-criticalSeverity = Severity 2--errorSeverity :: Severity-errorSeverity = Severity 3--warningSeverity :: Severity-warningSeverity = Severity 4--noticeSeverity :: Severity-noticeSeverity = Severity 5--informationalSeverity :: Severity-informationalSeverity = Severity 6--debugSeverity :: Severity-debugSeverity = Severity 7---- | An rfc 5424 facility-newtype Facility = Facility {fromFacility :: Int}-  deriving (Eq, Ord, Show, Generic, NFData)--kernelMessages :: Facility-kernelMessages = Facility 0--userLevelMessages :: Facility-userLevelMessages = Facility 1--mailSystem :: Facility-mailSystem = Facility 2--systemDaemons :: Facility-systemDaemons = Facility 3--securityAuthorizationMessages4 :: Facility-securityAuthorizationMessages4 = Facility 4--linePrinterSubsystem :: Facility-linePrinterSubsystem = Facility 6--networkNewsSubsystem :: Facility-networkNewsSubsystem = Facility 7--uucpSubsystem :: Facility-uucpSubsystem = Facility 8--clockDaemon :: Facility-clockDaemon = Facility 9--securityAuthorizationMessages10 :: Facility-securityAuthorizationMessages10 = Facility 10--ftpDaemon :: Facility-ftpDaemon = Facility 11--ntpSubsystem :: Facility-ntpSubsystem = Facility 12--logAuditFacility :: Facility-logAuditFacility = Facility 13--logAlertFacility :: Facility-logAlertFacility = Facility 14--clockDaemon2 :: Facility-clockDaemon2 = Facility 15--local0 :: Facility-local0 = Facility 16--local1 :: Facility-local1 = Facility 17--local2 :: Facility-local2 = Facility 18--local3 :: Facility-local3 = Facility 19--local4 :: Facility-local4 = Facility 20--local5 :: Facility-local5 = Facility 21--local6 :: Facility-local6 = Facility 22--local7 :: Facility-local7 = Facility 23--makeLenses ''StructuredDataElement-makeLenses ''LogMessage--addSyslogTimestamps-  :: ( MonadIO io-     , SetMember Lift (Lift io) e-     , Member (Logs LogMessage) e-     , Member (MessageFactoryReader LogMessage) e-     )-  => Eff e a-  -> Eff e a-addSyslogTimestamps = composeMessageFactories $ \m -> do-  now <- getCurrentTime-  return (m & lmTimestamp ?~ now)--syslogMsg-  :: ( HasCallStack-     , MonadIO io-     , SetMember Lift (Lift io) e-     , Member (Logs LogMessage) e-     , Member (MessageFactoryReader LogMessage) e-     )-  => (LogMessage -> LogMessage)-  -> Eff e ()-syslogMsg f = mkLogMsg (f . setCallStack callStack)- where-  setCallStack :: CallStack -> LogMessage -> LogMessage-  setCallStack cs m = case getCallStack cs of-    []              -> m-    (_, srcLoc) : _ -> m & lmSrcLoc ?~ srcLoc--withSyslog-  :: forall io e a-   . ( Member (Logs LogMessage) e-     , Default LogMessage-     , MonadIO io-     , SetMember Lift (Lift io) e-     )-  => Eff (MessageFactoryReader LogMessage ': e) a-  -> Eff e a-withSyslog = withLogMessageFactory . addSyslogTimestamps

@@ -1,5 +1,4 @@-module Common-where+module Common where  import           Control.Concurrent.STM import           Control.Eff.Concurrent.Process@@ -20,7 +19,7 @@ timeoutSeconds seconds = Timeout (seconds * 1000000) (show seconds ++ "s")  withTestLogC-  :: (e -> LogChannel String -> IO ())+  :: (e -> LogChannel LogMessage -> IO ())   -> (IO (e -> IO ()) -> TestTree)   -> TestTree withTestLogC doSchedule k = withResource@@ -35,16 +34,16 @@     )   ) -testLogC :: IO (LogChannel String)+testLogC :: IO (LogChannel LogMessage) testLogC =-  filterLogChannel (\m -> take (length logPrefix) m == logPrefix)-    <$> forkLogger 1 (putStrLn) Nothing+  filterLogChannel (\m -> take (length logPrefix) (_lmMessage m) == logPrefix)+    <$> forkLogger 1 printLogMessage Nothing -testLogJoin :: LogChannel String -> IO ()-testLogJoin = joinLogChannel Nothing+testLogJoin :: LogChannel LogMessage -> IO ()+testLogJoin = joinLogChannel -tlog :: Member (Logs String) r => String -> Eff r ()-tlog = logMsg . (logPrefix ++)+tlog :: Member (Logs LogMessage) r => String -> Eff r ()+tlog = logInfo . (logPrefix ++)  logPrefix :: String logPrefix = "[TEST] "@@ -58,7 +57,7 @@  scheduleAndAssert   :: forall r-   . (SetMember Lift (Lift IO) r, Member (Logs String) r)+   . (SetMember Lift (Lift IO) r, Member (Logs LogMessage) r)   => IO (Eff (Process r ': r) () -> IO ())   -> (  (String -> Bool -> Eff (Process r ': r) ())      -> Eff (Process r ': r) ()@@ -78,7 +77,7 @@  applySchedulerFactory   :: forall r-   . (Member (Logs String) r, SetMember Lift (Lift IO) r)+   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)   => IO (Eff (Process r ': r) () -> IO ())   -> Eff (Process r ': r) ()   -> IO ()

@@ -33,3 +33,6 @@  toOtherLogMsg :: ('[Logs String, Logs OtherLogMsg] <:: e) => String -> Eff e () toOtherLogMsg = logMsg . OtherLogMsg++demo2 :: Member (Logs LogMessage) e => Eff e ()+demo2 = relogAsDebugMessages demo

@@ -1,5 +1,4 @@-module ProcessBehaviourTestCases-where+module ProcessBehaviourTestCases where  import           Data.List                      ( sort ) import           Data.Dynamic@@ -33,7 +32,7 @@   (withTestLogC     (\e logC ->         -- void (runLift (logToChannel logC (SingleThreaded.schedule (return ()) e)))-      let runEff :: Eff '[Logs String, Lift IO] a -> IO a+      let runEff :: Eff '[Logs LogMessage, Lift IO] a -> IO a           runEff = runLift . logToChannel logC       in  void $ SingleThreaded.scheduleM runEff yield e     )@@ -43,7 +42,7 @@  allTests   :: forall r-   . (Member (Logs String) r, SetMember Lift (Lift IO) r)+   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)   => IO (Eff (Process r ': r) () -> IO ())   -> TestTree allTests schedulerFactory = localOption@@ -61,7 +60,7 @@  yieldLoopTests   :: forall r-   . (Member (Logs String) r, SetMember Lift (Lift IO) r)+   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)   => IO (Eff (Process r ': r) () -> IO ())   -> TestTree yieldLoopTests schedulerFactory@@ -100,7 +99,7 @@  pingPongTests   :: forall r-   . (Member (Logs String) r, SetMember Lift (Lift IO) r)+   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)   => IO (Eff (Process r ': r) () -> IO ())   -> TestTree pingPongTests schedulerFactory = testGroup@@ -175,7 +174,7 @@  errorTests   :: forall r-   . (Member (Logs String) r, SetMember Lift (Lift IO) r)+   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)   => IO (Eff (Process r ': r) () -> IO ())   -> TestTree errorTests schedulerFactory@@ -249,7 +248,7 @@  concurrencyTests   :: forall r-   . (Member (Logs String) r, SetMember Lift (Lift IO) r)+   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)   => IO (Eff (Process r ': r) () -> IO ())   -> TestTree concurrencyTests schedulerFactory@@ -292,10 +291,11 @@                 m <- receiveMessage px                 void (sendMessage px me m)               )-            child2 <- spawn (foreverCheap (void (sendMessage px 888 (toDyn ""))))-            True   <- sendMessageChecked px child1 (toDyn "test")-            i      <- receiveMessageAs px-            True   <- sendShutdownChecked px child2+            child2 <- spawn+              (foreverCheap (void (sendMessage px 888 (toDyn ""))))+            True <- sendMessageChecked px child1 (toDyn "test")+            i    <- receiveMessageAs px+            True <- sendShutdownChecked px child2             assertEff "" (i == "test")         , testCase "most processes send foreverCheap"         $ scheduleAndAssert schedulerFactory@@ -395,7 +395,7 @@  exitTests   :: forall r-   . (Member (Logs String) r, SetMember Lift (Lift IO) r)+   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)   => IO (Eff (Process r ': r) () -> IO ())   -> TestTree exitTests schedulerFactory =@@ -495,8 +495,8 @@           , (howToExit, doExit    ) <-             [ ("normally"        , void (exitNormally px))             , ("simply returning", return ())-            , ("raiseError"      , void (raiseError px "test error raised"))-            , ("exitWithError"   , void (exitWithError px "test error exit"))+            , ("raiseError", void (raiseError px "test error raised"))+            , ("exitWithError", void (exitWithError px "test error exit"))             , ( "sendShutdown to self"               , do                 me <- self px@@ -509,7 +509,7 @@  sendShutdownTests   :: forall r-   . (Member (Logs String) r, SetMember Lift (Lift IO) r)+   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)   => IO (Eff (Process r ': r) () -> IO ())   -> TestTree sendShutdownTests schedulerFactory =