diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/examples/example-1/Main.hs b/examples/example-1/Main.hs --- a/examples/example-1/Main.hs +++ b/examples/example-1/Main.hs @@ -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 diff --git a/examples/example-2/Main.hs b/examples/example-2/Main.hs --- a/examples/example-2/Main.hs +++ b/examples/example-2/Main.hs @@ -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 diff --git a/examples/example-4/Main.hs b/examples/example-4/Main.hs --- a/examples/example-4/Main.hs +++ b/examples/example-4/Main.hs @@ -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 diff --git a/extensible-effects-concurrent.cabal b/extensible-effects-concurrent.cabal --- a/extensible-effects-concurrent.cabal +++ b/extensible-effects-concurrent.cabal @@ -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 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, diff --git a/src/Control/Eff/Concurrent/Api/Observer.hs b/src/Control/Eff/Concurrent/Api/Observer.hs --- a/src/Control/Eff/Concurrent/Api/Observer.hs +++ b/src/Control/Eff/Concurrent/Api/Observer.hs @@ -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 diff --git a/src/Control/Eff/Concurrent/Api/Observer/Queue.hs b/src/Control/Eff/Concurrent/Api/Observer/Queue.hs --- a/src/Control/Eff/Concurrent/Api/Observer/Queue.hs +++ b/src/Control/Eff/Concurrent/Api/Observer/Queue.hs @@ -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 diff --git a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs --- a/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +++ b/src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs @@ -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) diff --git a/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs b/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs --- a/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs +++ b/src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs @@ -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 diff --git a/src/Control/Eff/Log/Channel.hs b/src/Control/Eff/Log/Channel.hs --- a/src/Control/Eff/Log/Channel.hs +++ b/src/Control/Eff/Log/Channel.hs @@ -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) diff --git a/src/Control/Eff/Log/Handler.hs b/src/Control/Eff/Log/Handler.hs --- a/src/Control/Eff/Log/Handler.hs +++ b/src/Control/Eff/Log/Handler.hs @@ -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 diff --git a/src/Control/Eff/Log/Message.hs b/src/Control/Eff/Log/Message.hs --- a/src/Control/Eff/Log/Message.hs +++ b/src/Control/Eff/Log/Message.hs @@ -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 () diff --git a/test/LoggingTests.hs b/test/LoggingTests.hs --- a/test/LoggingTests.hs +++ b/test/LoggingTests.hs @@ -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) diff --git a/test/ProcessBehaviourTestCases.hs b/test/ProcessBehaviourTestCases.hs --- a/test/ProcessBehaviourTestCases.hs +++ b/test/ProcessBehaviourTestCases.hs @@ -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 )