packages feed

extensible-effects-concurrent 0.9.2.2 → 0.10.0

raw patch · 14 files changed

+307/−265 lines, 14 filesdep +transformers-base

Dependencies added: transformers-base

Files

ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for extensible-effects-concurrent +## 0.10.0++- Re-introduce a Logs Effect but keep the LogWriter Reader+- Get rid of the LogWriterProxy and the implicit argument+- Make logging stricter: require log message to be NFData instances+ ## 0.9.2  - Try to adapt the dependency versions to make hackage happy again
examples/example-1/Main.hs view
@@ -38,8 +38,8 @@ example   :: ( HasCallStack      , SetMember Process (Process q) r-     , HasLoggingIO r-     , HasLoggingIO q+     , HasLogging IO r+     , HasLogging IO q      )   => SchedulerProxy q   -> Eff r ()@@ -73,7 +73,7 @@  testServerLoop   :: forall r q-   . (HasCallStack, SetMember Process (Process q) r, HasLoggingIO q)+   . (HasCallStack, SetMember Process (Process q) r, HasLogging IO q)   => SchedulerProxy q   -> Eff r (Server TestApi) testServerLoop px = spawnServer px
examples/example-2/Main.hs view
@@ -5,7 +5,6 @@ import           Control.Eff import           Control.Eff.Concurrent import           Control.Eff.State.Strict-import           Control.Eff.Lift import           Control.Monad  main :: IO ()@@ -33,7 +32,10 @@   forgetObserverMessage = UnobserveCounter  logCounterObservations-  :: (SetMember Process (Process q) r, HasLogging m q)+  :: ( SetMember Process (Process q) r+     , Member (Logs LogMessage) q+     , Member (Logs LogMessage) r+     )   => SchedulerProxy q   -> Eff r (Server (CallbackObserver Counter)) logCounterObservations px = spawnCallbackObserver@@ -45,13 +47,12 @@   )  counterHandler-  :: forall r q m+  :: forall r q    . ( Member (State (Observers Counter)) r      , Member (State Integer) r-     , HasLogging m q-     , HasLogging m r      , SetMember Process (Process q) r-     , Lifted m r+     , Member (Logs LogMessage) q+     , Member (Logs LogMessage) r      )   => SchedulerProxy q   -> ApiHandler Counter r@@ -87,10 +88,10 @@ deriving instance Show (Api PocketCalc x)  pocketCalcHandler-  :: forall r q m+  :: forall r q    . ( Member (State Integer) r-     , HasLogging m r      , SetMember Process (Process q) r+     , Member (Logs LogMessage) r      )   => SchedulerProxy q   -> ApiHandler PocketCalc r@@ -114,8 +115,11 @@     return HandleNextRequest  serverLoop-  :: forall r q m-   . (HasLogging m r, HasLogging m q, SetMember Process (Process q) r)+  :: forall r q+   . ( Member (Logs LogMessage) q+     , Member (Logs LogMessage) r+     , SetMember Process (Process q) r+     )   => SchedulerProxy q   -> Eff r () serverLoop px = evalState @Integer@@ -125,7 +129,11 @@  -- ** Counter client counterExample-  :: (SetMember Process (Process q) r, HasLogging m r, HasLogging m q, q <:: r)+  :: ( SetMember Process (Process q) r+     , Member (Logs LogMessage) q+     , Member (Logs LogMessage) r+     , q <:: r+     )   => SchedulerProxy q   -> Eff r Integer counterExample px = execState (0 :: Integer) $ do
examples/example-4/Main.hs view
@@ -19,7 +19,7 @@  newtype WhoAreYou = WhoAreYou ProcessId deriving (Typeable, NFData) -firstExample :: (HasLoggingIO q) => SchedulerProxy q -> Eff (Process q ': q) ()+firstExample :: (HasLogging IO q) => SchedulerProxy q -> Eff (Process q ': q) () firstExample px = do   person <- spawn     (do
extensible-effects-concurrent.cabal view
@@ -1,5 +1,5 @@ name:           extensible-effects-concurrent-version:        0.9.2.2+version:        0.10.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@@ -49,7 +49,8 @@       process >= 1.6 && < 1.7,       monad-control >= 1.0 && < 1.1,       extensible-effects >= 3.1 && <4,-      stm >= 2.4.5 && <2.6+      stm >= 2.4.5 && <2.6,+      transformers-base >= 0.4 && < 0.5   autogen-modules: Paths_extensible_effects_concurrent   exposed-modules:                   Control.Eff.Loop,
src/Control/Eff/Concurrent/Api/Observer.hs view
@@ -179,12 +179,12 @@ -- | Start a new process for an 'Observer' that schedules -- all observations to an effectful callback. spawnCallbackObserver-  :: forall o r q logWriter+  :: forall o r q    . ( SetMember Process (Process q) r      , Typeable o      , Show (Observation o)      , Observable o-     , HasLogging logWriter q+     , Member (Logs LogMessage) q      , HasCallStack      )   => SchedulerProxy q@@ -205,12 +205,13 @@ -- -- @since 0.3.0.0 spawnLoggingObserver-  :: forall o r q logWriter+  :: forall o r q    . ( SetMember Process (Process q) r      , Typeable o      , Show (Observation o)      , Observable o-     , HasLogging logWriter q+     , Member (Logs LogMessage) q+     , Member (Logs LogMessage) r      , HasCallStack      )   => SchedulerProxy q
src/Control/Eff/Concurrent/Api/Observer/Queue.hs view
@@ -47,7 +47,7 @@      , HasCallStack      , MonadIO (Eff r)      , Typeable o-     , HasLoggingIO r+     , HasLogging IO r      )   => Eff r (Observation o) readObservationQueue = do@@ -65,7 +65,7 @@      , HasCallStack      , MonadIO (Eff r)      , Typeable o-     , HasLoggingIO r+     , HasLogging IO r      )   => Eff r (Maybe (Observation o)) tryReadObservationQueue = do@@ -82,7 +82,7 @@      , HasCallStack      , MonadIO (Eff r)      , Typeable o-     , HasLoggingIO r+     , HasLogging IO r      )   => Eff r [Observation o] flushObservationQueue = do@@ -99,8 +99,8 @@      , Typeable o      , Show (Observation o)      , Observable o-     , HasLoggingIO q-     , HasLoggingIO r+     , HasLogging IO q+     , HasLogging IO r      , Lifted IO r      , HasCallStack      )@@ -124,8 +124,8 @@      , Typeable o      , Show (Observation o)      , Observable o-     , HasLoggingIO r-     , HasLoggingIO q+     , HasLogging IO r+     , HasLogging IO q      , Lifted IO q      , HasCallStack      )@@ -176,7 +176,7 @@  withQueue   :: forall a b e-   . (HasCallStack, Typeable a, Show (Observation a), HasLoggingIO e)+   . (HasCallStack, Typeable a, Show (Observation a), HasLogging IO e)   => Int   -> Eff (ObservationQueueReader a ': e) b   -> Eff e b
src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs view
@@ -122,7 +122,9 @@ -- | Create a new 'SchedulerState' run an IO action, catching all exceptions, -- and when the actions returns, clean up and kill all processes. withNewSchedulerState-  :: (HasLoggingIO SchedulerIO, HasCallStack) => Eff SchedulerIO () -> Eff LoggingAndIO ()+  :: (HasLogging IO SchedulerIO, HasCallStack)+  => Eff SchedulerIO ()+  -> Eff LoggingAndIO () withNewSchedulerState mainProcessAction =   Exceptions.tryAny (lift (atomically newSchedulerState))     >>= either@@ -176,13 +178,13 @@ -- | Basic effects: 'Logs' 'LogMessage' and 'Lift' IO type LoggingAndIO =               '[ Logs LogMessage+               , LogWriterReader LogMessage IO                , Lift IO                ]  -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output.-defaultMain-  :: HasCallStack => (HasLogWriterProxy IO => Eff ProcEff ()) -> IO ()+defaultMain :: HasCallStack => Eff ProcEff () -> IO () defaultMain c =   withAsyncLogChannel 1024     (multiMessageLogWriter ($ printLogMessage))@@ -191,12 +193,8 @@ -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output. defaultMainWithLogChannel-  :: HasCallStack-  => (HasLogWriterProxy IO => Eff ProcEff ())-  -> LogChannel LogMessage-  -> IO ()-defaultMainWithLogChannel c =-  handleLoggingAndIO_ (schedule c)+  :: HasCallStack => Eff ProcEff () -> LogChannel LogMessage -> IO ()+defaultMainWithLogChannel = handleLoggingAndIO_ . schedule  -- | A 'SchedulerProxy' for 'SchedulerIO' forkIoScheduler :: SchedulerProxy SchedulerIO@@ -222,7 +220,7 @@ -- ** MessagePassing execution  handleProcess-  :: (HasLoggingIO SchedulerIO, HasCallStack)+  :: (HasLogging IO SchedulerIO, HasCallStack)   => ProcessInfo   -> Eff ProcEff ProcessExitReason   -> Eff SchedulerIO ProcessExitReason@@ -384,7 +382,7 @@ -- application. This function takes a 'Process' on top of the 'SchedulerIO' -- effect and a 'LogChannel' for concurrent logging. schedule-  :: (HasLoggingIO SchedulerIO, HasCallStack)+  :: (HasLogging IO SchedulerIO, HasCallStack)   => Eff ProcEff ()   -> Eff LoggingAndIO () schedule procEff =@@ -403,7 +401,7 @@   ) >>= restoreM  spawnNewProcess-  :: (HasLoggingIO SchedulerIO, HasCallStack)+  :: (HasLogging IO SchedulerIO, HasCallStack)   => Eff ProcEff ()   -> Eff SchedulerIO (ProcessId, Async ProcessExitReason) spawnNewProcess mfa = do@@ -424,8 +422,9 @@        let pid = procInfo ^. processId           logAppendProcInfo =-            interceptLogging-              (lift . setLogMessageThreadId >=> logMsg . addProcessId)+            traverseLogMessages+              (   lift . traverse setLogMessageThreadId+              >=> traverse (return . addProcessId))             where               addProcessId =                 over lmProcessId (maybe (Just (printf "% 9s" (show pid))) Just)
src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs view
@@ -36,16 +36,8 @@ -- @schedulePure == runIdentity . 'scheduleM' (Identity . run)  (return ())@ -- -- @since 0.3.0.2-schedulePure-  :: (  HasLogWriterProxy Identity-     => Eff (ConsProcess '[LogsM LogMessage Identity, Lift Identity]) a-     )-  -> Either String a-schedulePure e = runIdentity-  (scheduleM (runLift . handleLogs traceLogMessageWriter)-             (return ())-             (usingLogWriterProxy (LogWriterProxy @Identity) e)-  )+schedulePure :: Eff (ConsProcess '[Logs LogMessage]) a -> Either String a+schedulePure e = run (scheduleM ignoreLogs (return ()) e)  -- | Invoke 'schedule' with @lift 'Control.Concurrent.yield'@ as yield effect. -- @scheduleIO runEff == 'scheduleM' (runLift . runEff) (liftIO 'yield')@@@ -78,9 +70,9 @@ scheduleIOWithLogging   :: (NFData l)   => LogWriter l IO-  -> Eff (ConsProcess '[Logs l, Lift IO]) a+  -> Eff (ConsProcess '[Logs l, LogWriterReader l IO, Lift IO]) a   -> IO (Either String a)-scheduleIOWithLogging h = scheduleIO (handleLogs h)+scheduleIOWithLogging h = scheduleIO (writeLogs h)  -- | Handle the 'Process' effect, as well as all lower effects using an effect handler function. --@@ -105,10 +97,9 @@   -> m () -- ^ An that performs a __yield__ w.r.t. the underlying effect   --  @r@. E.g. if @Lift IO@ is present, this might be:   --  @lift 'Control.Concurrent.yield'.-  -> (HasLogWriterProxy m => Eff (ConsProcess r) a)+  -> Eff (ConsProcess r) a   -> m (Either String a)-scheduleM runEff yieldEff e' = do-  let e = (usingLogWriterProxy (LogWriterProxy @m) e')+scheduleM runEff yieldEff e = do   y <- runAsCoroutinePure runEff e   handleProcess runEff                 yieldEff@@ -315,10 +306,10 @@   cont :: Process r x -> (x -> Eff r (OnYield r v)) -> Eff r (OnYield r v)   cont YieldProcess               k  = return (OnYield k)   cont SelfPid                    k  = return (OnSelf k)-  cont (Spawn      e        )     k  = return (OnSpawn e k)-  cont (Shutdown   !sr      )     _k = return (OnShutdown sr)-  cont (RaiseError !e       )     _k = return (OnRaiseError e)-  cont (SendMessage !tp !msg)     k  = return (OnSend tp msg k)+  cont (Spawn      e            ) k  = return (OnSpawn e k)+  cont (Shutdown   !sr          ) _k = return (OnShutdown sr)+  cont (RaiseError !e           ) _k = return (OnRaiseError e)+  cont (SendMessage !tp !msg    ) k  = return (OnSend tp msg k)   cont (ReceiveSelectedMessage f) k  = return (OnRecv f k)   cont (SendShutdown !pid !sr   ) k  = return (OnSendShutdown pid sr k)   cont MakeReference              k  = return (OnMakeReference k)@@ -327,6 +318,7 @@ -- with string logging. type LoggingAndIo =               '[ Logs LogMessage+               , LogWriterReader LogMessage IO                , Lift IO                ] @@ -338,10 +330,14 @@ -- @String@ effects. defaultMain   :: HasCallStack-  => Eff '[Process '[Logs LogMessage, Lift IO], Logs LogMessage, Lift IO] ()+  => Eff+       ( ConsProcess+           '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO]+       )+       ()   -> IO () defaultMain =   void     . runLift-    . handleLogs (multiMessageLogWriter ($ printLogMessage))+    . writeLogs (multiMessageLogWriter ($ printLogMessage))     . scheduleMonadIOEff
src/Control/Eff/Log/Channel.hs view
@@ -21,7 +21,6 @@ import           Control.DeepSeq import           GHC.Stack - -- | Fork a new process in which the given log message writer, will listen -- on a message queue in a 'LogChannel', which is passed to the second function. -- If the function returns or throws, the logging process will be killed.@@ -68,11 +67,11 @@ -- When the queue is full, flush it handleLoggingAndIO   :: (NFData m, HasCallStack)-  => (HasLogWriterProxy IO => Eff '[Logs m, Lift IO] a)+  => Eff '[Logs m, LogWriterReader m IO, Lift IO] a   -> LogChannel m   -> IO a handleLoggingAndIO e lc = runLift-  (handleLogs (foldingLogWriter (traverse_ logChannelPutIO)) e)+  (writeLogs (foldingLogWriter (traverse_ logChannelPutIO)) e)  where   logQ = fromLogChannel lc   logChannelPutIO (force -> me) = do@@ -86,7 +85,7 @@ -- | Like 'handleLoggingAndIO' but return @()@. handleLoggingAndIO_   :: (NFData m, HasCallStack)-  => (HasLogWriterProxy IO => Eff '[Logs m, Lift IO] a)+  => Eff '[Logs m, LogWriterReader m IO, Lift IO] a   -> LogChannel m   -> IO () handleLoggingAndIO_ e lc = void (handleLoggingAndIO e lc)
src/Control/Eff/Log/Handler.hs view
@@ -1,47 +1,157 @@-{-# LANGUAGE ImplicitParams #-}- -- | A logging effect based on 'Control.Monad.Log.MonadLog'. module Control.Eff.Log.Handler   ( logMsg   , logMsgs-  , LogsM-  , Logs-  , handleLogs-  , ignoreLogs+  , HasLogWriter   , mapLogMessages   , filterLogMessages-  , interceptLogging-  , HasLogWriter-  , HasLogWriterIO+  , traverseLogMessages+  , changeLogWriter+  , ignoreLogs+  , traceLogs   , LogWriter()-  , writeAllLogMessages+  , LogWriterReader   , foldingLogWriter+  , writeAllLogMessages   , singleMessageLogWriter   , multiMessageLogWriter-  , HasLogWriterProxy-  , LogWriterProxy(..)-  , usingLogWriterProxy-  , logWriterProxy   , askLogWriter+  , Logs()+  , writeLogs+  , runLogs   ) where  import           Control.DeepSeq import           Control.Eff                   as Eff+import           Control.Eff.Extend import           Control.Eff.Reader.Strict import           Control.Eff.Lift              as Eff-import           Data.Foldable                  ( traverse_, toList )-import           Data.Kind-import           Data.Functor.Identity-import           GHC.Stack+import           Data.Foldable                  ( traverse_ ) import           Data.Default+import           Control.Monad+import           Control.Monad.Trans.Control    ( MonadBaseControl+                                                  ( restoreM+                                                  , liftBaseWith+                                                  , StM+                                                  )+                                                )+import           Control.Monad.Base             ( MonadBase() )+import           Debug.Trace +-- * Message Logging Effect++-- | Log a message. The message is reduced to normal form (strict).+logMsg :: (NFData m, Member (Logs m) e) => m -> Eff e ()+logMsg (force -> msg) = logMsgs [msg]++-- | Log a bunch of messages. This might be more efficient than calling 'logMsg'+-- multiple times.+-- The messages are reduced to normal form (strict).+logMsgs+  :: (Traversable f, MonadPlus f, NFData1 f, NFData m, Member (Logs m) e)+  => f m+  -> Eff e ()+logMsgs !msgs = rnf1 msgs `seq` send (LogMsgs msgs)++-- ** Filter and Transform Log Messages++-- | Map a pure function over log messages.+mapLogMessages+  :: forall m r b . (Member (Logs m) r) => (m -> m) -> Eff r b -> Eff r b+mapLogMessages f = interpose return go+ where+  go :: Logs m a -> Arr r a b -> Eff r b+  go (LogMsgs ms) k = logMsgs (fmap f ms) >>= k++-- | Keep only those messages, for which the predicate holds.+filterLogMessages+  :: forall m r b . (Member (Logs m) r) => (m -> Bool) -> Eff r b -> Eff r b+filterLogMessages predicate = interpose return go+ where+  go :: Logs m a -> Arr r a b -> Eff r b+  go (LogMsgs ms) k = logMsgs (mfilter predicate ms) >>= k++-- ** Filter and Transform Log Messages effectfully++-- | Map an 'Eff'ectful function over every bunch of log messages.+--+-- For example, to attach the current time to each log message:+--+-- > appendTimestamp+-- >  :: ( Member (Logs String) e+-- >     , Lifted IO e)+-- >  => Eff e a+-- >  -> Eff e a+-- > appendTimestamp = traverseLogMessages $ \ms -> do+-- >   now <- lift getCurrentTime+-- >   return (fmap (show now ++) ms)+traverseLogMessages+  :: forall m r b+   . (Member (Logs m) r)+  => (  forall f+      . (MonadPlus f, Traversable f, NFData1 f)+     => f m+     -> Eff r (f m)+     )+  -> Eff r b+  -> Eff r b+traverseLogMessages f = interpose return go+ where+  go :: Logs m a -> Arr r a b -> Eff r b+  go (LogMsgs ms) k = f ms >>= logMsgs >>= k++-- ** Change the Log Writer++-- | Change the way log messages are *written*.+-- Replaces the existing 'LogWriter' by a new one. The new 'LogWriter'+-- is constructed from a function that gets a /bunch/ of messages and+-- returns an 'Eff'ect.+-- That effect has a 'Reader' for the previous 'LogWriter' and 'Lift's+-- the log writer base monad.+changeLogWriter+  :: forall r m h a+   . (Monad h, Lifted h r, Member (Reader (LogWriter m h)) r)+  => (  forall f+      . (Traversable f, NFData1 f, MonadPlus f)+     => f m+     -> Eff '[Reader (LogWriter m h), Lift h] ()+     )+  -> Eff r a+  -> Eff r a+changeLogWriter interceptor =+  let replaceWriter old = LogWriter (runLift . runReader old . interceptor)+  in  local replaceWriter++-- * Handle Log Messages++-- | Throw away all log messages.+ignoreLogs :: forall message r a . Eff (Logs message ': r) a -> Eff r a+ignoreLogs = handle_relay return go+ where+  go :: Logs message v -> Arr r v a -> Eff r a+  go (LogMsgs _) k = k ()++-- | Trace all log messages using 'traceM'. The message value is+-- converted to 'String' using the given function.+traceLogs+  :: forall message r a+   . (message -> String)+  -> Eff (Logs message ': r) a+  -> Eff r a+traceLogs toString = handle_relay return go+ where+  go :: Logs message v -> Arr r v a -> Eff r a+  go (LogMsgs ms) k = traverse_ (traceM . toString) ms >> k ()++-- ** Log Message Writer Creation+ -- | A function that takes a log message and returns an effect that -- /logs/ the message. newtype LogWriter message writerM =   LogWriter   { runLogWriter-      :: forall f. (HasCallStack, Traversable f, Foldable f, Functor f)+      :: forall f. (MonadPlus f, Traversable f, NFData1 f)       => f message       -> writerM ()   }@@ -49,31 +159,40 @@ instance Applicative w => Default (LogWriter m w) where   def = LogWriter (const (pure ())) --- | Efficiently apply the 'LogWriter' to a 'Foldable' container of log--- messages.-writeAllLogMessages-  :: (Foldable f, Functor f, Traversable f, Applicative writerM, HasCallStack)-  => LogWriter message writerM -> f message -> writerM ()-writeAllLogMessages = runLogWriter+-- | Type alias for the 'Reader' effect that writes logs+type LogWriterReader message writerM =+  Reader (LogWriter message writerM)  -- | Create a 'LogWriter' from a function that can write--- a 'Foldable' container.+-- a 'Traversable' container. foldingLogWriter-  :: (forall f. (Foldable f, Traversable f, HasCallStack) => f message -> writerM ())+  :: (  forall f+      . (MonadPlus f, Traversable f, NFData1 f)+     => f message+     -> writerM ()+     )   -> LogWriter message writerM foldingLogWriter = LogWriter +-- | Efficiently apply the 'LogWriter' to a 'Traversable' container of log+-- messages.+writeAllLogMessages+  :: (NFData1 f, MonadPlus f, Traversable f, Applicative writerM)+  => LogWriter message writerM+  -> f message+  -> writerM ()+writeAllLogMessages = runLogWriter+ -- | Create a 'LogWriter' from a function that is applied to each -- individual log message. NOTE: This is probably the simplest, -- but also the most inefficient and annoying way to make -- a 'LogWriter'. Better use 'foldingLogWriter' or even -- 'multiMessageLogWriter'. singleMessageLogWriter-  :: (Applicative writerM, HasCallStack)+  :: (Applicative writerM)   => (message -> writerM ())   -> LogWriter message writerM-singleMessageLogWriter writeMessage =-  foldingLogWriter (traverse_ writeMessage)+singleMessageLogWriter writeMessage = foldingLogWriter (traverse_ writeMessage)  -- | Create a 'LogWriter' from a function that is applied to each -- individual log message. Don't be scared by the type signature,@@ -85,142 +204,85 @@ -- >      withFile fn AppendMode (writeLogMessageWith . hPutStrLn)) -- multiMessageLogWriter-  :: (Applicative writerM, HasCallStack)+  :: (Applicative writerM)   => (((message -> writerM ()) -> writerM ()) -> writerM ())   -> LogWriter message writerM multiMessageLogWriter withMessageWriter =-  foldingLogWriter-    (\xs -> withMessageWriter (\writer -> traverse_ writer xs))+  foldingLogWriter (\xs -> withMessageWriter (\writer -> traverse_ writer xs)) --- | Logging effect type, parameterized by a log message type. This is a reader--- for a 'LogWriter'.-type LogsM message writerM = Reader (LogWriter message writerM)+-- | Get the current 'LogWriter'+askLogWriter+  :: forall m h r . (Member (Reader (LogWriter m h)) r) => Eff r (LogWriter m h)+askLogWriter = ask --- | The logging effect on IO.-type Logs message = LogsM message IO+-- ** Low-Level Log Message Sending  -- | A constraint that combines constraints for logging into any -- log writer monad. type HasLogWriter message logWriterMonad effects =-  ( Member (LogsM message logWriterMonad) effects+  ( Member (Reader (LogWriter message logWriterMonad)) effects+  , Member (Logs message) effects   , NFData message   , Monad logWriterMonad-  , HasLogWriterProxy logWriterMonad-  , Lifted logWriterMonad effects )---- | A constraint that combines constraints for IO based logging.-type HasLogWriterIO message effects =-  ( Member (Logs message) effects-  , NFData message-  , HasLogWriterProxy IO-  , Lifted IO effects )---- | Type constraint alias for the implicit 'LogWriterProxy'-type HasLogWriterProxy m = ( ?logWriterProxy :: LogWriterProxy m )---- | A proxy type to carry the 'LogWriter' effects.-data LogWriterProxy (e :: Type -> Type) = LogWriterProxy---- | Set the implicit parameter defined in 'HasLogWriterProxy' for function--- applications like 'logMsg'-usingLogWriterProxy-  :: forall e r a-  . LogWriterProxy e-  -> (HasLogWriterProxy e => Eff r a) -> Eff r a-usingLogWriterProxy px e = let ?logWriterProxy = px in e---- | Return the current 'LogWriterProxy'-logWriterProxy :: HasLogWriterProxy e => LogWriterProxy e-logWriterProxy = ?logWriterProxy---- | Get the current 'LogWriter'-askLogWriter :: forall m h r . (HasLogWriter m h r) => Eff r (LogWriter m h)-askLogWriter = ask+  , Lifted logWriterMonad effects+  ) --- | Log a message.-logMsg :: (NFData m, HasLogWriter m h r) => m -> Eff r ()-logMsg !(force -> m) = do-  lw <- askLogWriter-  lift (runLogWriter lw (Identity m))+-- | This effect sends log messages.+-- The logs are not sent one-by-one, but always in batches of+-- containers that must be 'Traversable' and 'MonadPlus' instances.+-- Log messages are consumed by 'LogWriter's installed via+-- 'runLogs' or more high level functions like 'writeLogs'.+data Logs m v where+  LogMsgs+    :: (Traversable f, MonadPlus f, NFData1 f, NFData m)+    => f m+    -> Logs m () --- | Log a bunch of messages. This might be more efficient than calling 'logMsg'--- multiple times.-logMsgs :: (NFData (f m), HasLogWriter m h r, Functor f, Traversable f, Foldable f) => f m -> Eff r ()-logMsgs !(force -> m) = do-  lw <- askLogWriter-  lift (runLogWriter lw m)+-- | Install 'Logs' handler that 'ask's for a 'LogWriter' for the+-- message type and applies the log writer to the messages.+runLogs+  :: forall m h e b+   . (Applicative h, Lifted h e, Member (LogWriterReader m h) e)+  => Eff (Logs m ': e) b+  -> Eff e b+runLogs = handle_relay return go+ where+  go :: Logs m a -> Arr e a b -> Eff e b+  go (LogMsgs ms) k = do+    logWrtr <- ask+    lift (writeAllLogMessages logWrtr ms)+    k () --- | 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+-- | Handle log message effects by a monadic action, e.g. an IO action+-- to send logs to the console output or a log-server.+-- The monadic log writer action is wrapped in a newtype called+-- 'LogWriter'. ----- 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 h a-   . (HasLogWriter m h r)-  => (m -> Eff '[LogsM m h, Lift h] ())-  -> (HasLogWriterProxy h => Eff r a)+-- Use the smart constructors below to create them, e.g.+-- 'foldingLogWriter', 'singleMessageLogWriter' or+-- 'mulitMessageLogWriter'.+writeLogs+  :: forall message writerM r a+   . (Applicative writerM, Lifted writerM r)+  => LogWriter message writerM+  -> Eff (Logs message ': Reader (LogWriter message writerM) ': r) a   -> Eff r a-interceptLogging interceptor  =-  let replaceWriter old =-        multiMessageLogWriter-          ($ (runLift . runReader old . interceptor))-  in local replaceWriter+writeLogs w = runReader w . runLogs --- | Map a pure function over log messages.-mapLogMessages-  :: forall m h r a-   . (HasLogWriter m h r)-  => (m -> m)-  -> (HasLogWriterProxy h => Eff r a)-  -> Eff r a-mapLogMessages f =-  local @(LogWriter m h)-    (\(LogWriter old) ->-      LogWriter (\xs ->-        old (fmap f xs)))+-- | This instance allows liftings of the 'Logs' effect, but only, if there is+-- a 'LogWriter' in effect.+instance+  ( MonadBase m m+  , Lifted m r+  , MonadBaseControl m (Eff r)+  )+  => MonadBaseControl m (Eff (Logs l ': LogWriterReader l m ': r)) where --- | Filter which messages are handled.-filterLogMessages-  :: forall r m h a-   . (HasLogWriter m h r, HasCallStack)-  => (m -> Bool)-  -> (HasLogWriterProxy h => Eff r a)-  -> Eff r a-filterLogMessages predicate =-  local-    @(LogWriter m h)-    (\(LogWriter old) ->-      LogWriter (old . filter predicate . toList))+    type StM (Eff (Logs l ': LogWriterReader l m ': r)) a =+      StM (Eff r) a --- | Define the the 'LogWriter' callback and set the 'HasLogWriterProxy'--- constraint in the given log writer action. This assumes that the monad used--- is 'Lift'ed to @r@.-handleLogs-  :: forall message writerM r a-   . (Lifted writerM r)-  => LogWriter message writerM-  -> (HasLogWriterProxy writerM => Eff (LogsM message writerM ': r) a)-  -> Eff r a-handleLogs lw e =-  usingLogWriterProxy (LogWriterProxy @writerM) (runReader lw e)+    liftBaseWith f = do+      l <- askLogWriter+      raise (raise (liftBaseWith (\runInBase -> f (runInBase . writeLogs l)))) --- | Throw away all log messages.-ignoreLogs-  :: forall message m r a-  . (Lifted m r, Applicative m)-  => (HasLogWriterProxy m => Eff (LogsM message m ': r) a)-  -> Eff r a-ignoreLogs = handleLogs def+    restoreM = raise . raise . restoreM
src/Control/Eff/Log/Message.hs view
@@ -3,7 +3,6 @@ module Control.Eff.Log.Message   ( LogMessage(..)   , HasLogging-  , HasLoggingIO   , renderRFC5424   , printLogMessage   , ioLogMessageHandler@@ -121,9 +120,6 @@ -- in the monad, which is 'Lift'ed into a given @Eff@ effect list. type HasLogging writerM effect = (HasLogWriter LogMessage writerM effect) --- | Like 'HasLogging' but with 'IO' as effect.-type HasLoggingIO effect = (HasLogWriterIO LogMessage effect)- showLmMessage :: LogMessage -> [String] showLmMessage (LogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg _dist) =   if null msg@@ -271,9 +267,10 @@ ioLogMessageHandler   :: (HasCallStack, Lifted IO e)   => LogWriter String IO-  -> (HasLogWriterProxy IO => Eff (Logs LogMessage ': e) a)+  -> Eff (Logs LogMessage ': LogWriterReader LogMessage IO ': e) a   -> Eff e a-ioLogMessageHandler delegatee = handleLogs (ioLogMessageWriter delegatee)+ioLogMessageHandler delegatee =+  writeLogs (ioLogMessageWriter delegatee)  -- | An IO action that sets the current UTC time (see 'enableLogMessageTimestamps') -- in 'lmTimestamp'.@@ -307,11 +304,8 @@  -- | Log a 'String' as 'LogMessage' with a given 'Severity'. logWithSeverity-  :: ( HasLogWriterProxy h-     , HasCallStack-     , Monad h-     , Member (LogsM LogMessage h) e-     , Lifted h e+  :: ( HasCallStack+     , Member (Logs LogMessage) e      )   => Severity   -> String@@ -326,10 +320,7 @@ -- | Log a 'String' as 'emergencySeverity'. logEmergency   :: ( HasCallStack-     , HasLogWriterProxy h-     , Monad h-     , Member (LogsM LogMessage h) e-     , Lifted h e+     , Member (Logs LogMessage) e      )   => String   -> Eff e ()@@ -338,10 +329,7 @@ -- | Log a message with 'alertSeverity'. logAlert   :: ( HasCallStack-     , HasLogWriterProxy h-     , Monad h-     , Member (LogsM LogMessage h) e-     , Lifted h e+     , Member (Logs LogMessage) e      )   => String   -> Eff e ()@@ -350,10 +338,7 @@ -- | Log a 'criticalSeverity' message. logCritical   :: ( HasCallStack-     , HasLogWriterProxy h-     , Monad h-     , Member (LogsM LogMessage h) e-     , Lifted h e+     , Member (Logs LogMessage) e      )   => String   -> Eff e ()@@ -362,10 +347,7 @@ -- | Log a 'errorSeverity' message. logError   :: ( HasCallStack-     , HasLogWriterProxy h-     , Monad h-     , Member (LogsM LogMessage h) e-     , Lifted h e+     , Member (Logs LogMessage) e      )   => String   -> Eff e ()@@ -374,10 +356,7 @@ -- | Log a 'warningSeverity' message. logWarning   :: ( HasCallStack-     , HasLogWriterProxy h-     , Monad h-     , Member (LogsM LogMessage h) e-     , Lifted h e+     , Member (Logs LogMessage) e      )   => String   -> Eff e ()@@ -386,10 +365,7 @@ -- | Log a 'noticeSeverity' message. logNotice   :: ( HasCallStack-     , HasLogWriterProxy h-     , Monad h-     , Member (LogsM LogMessage h) e-     , Lifted h e+     , Member (Logs LogMessage) e      )   => String   -> Eff e ()@@ -398,10 +374,7 @@ -- | Log a 'informationalSeverity' message. logInfo   :: ( HasCallStack-     , HasLogWriterProxy h-     , Monad h-     , Member (LogsM LogMessage h) e-     , Lifted h e+     , Member (Logs LogMessage) e      )   => String   -> Eff e ()@@ -409,11 +382,8 @@  -- | Log a 'debugSeverity' message. logDebug-  :: ( HasLogWriterProxy h-     , HasCallStack-     , Monad h-     , Member (LogsM LogMessage h) e-     , Lifted h e+  :: ( HasCallStack+     , Member (Logs LogMessage) e      )   => String   -> Eff e ()
test/LoggingTests.hs view
@@ -9,7 +9,7 @@ import           Control.Concurrent.STM import           Control.DeepSeq -demo :: (HasLogWriterIO String e, HasLogWriterIO OtherLogMsg e) => Eff e ()+demo :: ([Logs String, Logs OtherLogMsg] <:: e) => Eff e () demo = do   logMsg "jo"   logMsg (OtherLogMsg "test 123")@@ -22,9 +22,9 @@       otherLogsQueue  <- newTQueueIO @OtherLogMsg       stringLogsQueue <- newTQueueIO @String       runLift-        (handleLogs+        (writeLogs           (multiMessageLogWriter ($ (atomically . writeTQueue stringLogsQueue)))-          (handleLogs+          (writeLogs             (multiMessageLogWriter ($ (atomically . writeTQueue otherLogsQueue))             )             (mapLogMessages @String reverse  demo)
test/ProcessBehaviourTestCases.hs view
@@ -37,7 +37,7 @@ test_singleThreaded = setTravisTestOptions $ withTestLogC   (\e logC ->         -- void (runLift (logToChannel logC (SingleThreaded.schedule (return ()) e)))-    let runEff :: Eff '[Logs LogMessage, Lift IO] a -> IO a+    let runEff :: Eff '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO] a -> IO a         runEff = flip handleLoggingAndIO logC     in  void $ SingleThreaded.scheduleM runEff yield e   )