extensible-effects-concurrent 0.18.1 → 0.19.0

raw patch · 34 files changed

+2483/−1959 lines, 34 filesdep +hostnamedep ~QuickCheckdep ~basedep ~extensible-effectsPVP ok

version bump matches the API change (PVP)

Dependencies added: hostname

Dependency ranges changed: QuickCheck, base, extensible-effects

API changes (from Hackage documentation)

- Control.Eff.Concurrent: defaultMainWithLogChannel :: HasCallStack => Eff InterruptableProcEff () -> LogChannel LogMessage -> IO ()

- Control.Eff.Concurrent: forkIoScheduler :: SchedulerProxy SchedulerIO

- Control.Eff.Concurrent: singleThreadedIoScheduler :: SchedulerProxy LoggingAndIo

- Control.Eff.Concurrent.Process.ForkIOScheduler: defaultMainWithLogChannel :: HasCallStack => Eff InterruptableProcEff () -> LogChannel LogMessage -> IO ()

- Control.Eff.Concurrent.Process.ForkIOScheduler: forkIoScheduler :: SchedulerProxy SchedulerIO

- Control.Eff.Concurrent.Process.SingleThreadedScheduler: singleThreadedIoScheduler :: SchedulerProxy LoggingAndIo

- Control.Eff.Log.Channel: data LogChannel message

- Control.Eff.Log.Channel: handleLoggingAndIO :: (NFData m, HasCallStack) => Eff '[Logs m, LogWriterReader m IO, Lift IO] a -> LogChannel m -> IO a

- Control.Eff.Log.Channel: handleLoggingAndIO_ :: (NFData m, HasCallStack) => Eff '[Logs m, LogWriterReader m IO, Lift IO] a -> LogChannel m -> IO ()

- Control.Eff.Log.Channel: withAsyncLogChannel :: forall message a len. (NFData message, Integral len) => len -> LogWriter message IO -> (LogChannel message -> IO a) -> IO a

- Control.Eff.Log.Handler: 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

- Control.Eff.Log.Handler: data LogWriter message writerM

- Control.Eff.Log.Handler: filterLogMessages :: forall m r b. (NFData m, Member (Logs m) r) => (m -> Bool) -> Eff r b -> Eff r b

- Control.Eff.Log.Handler: foldingLogWriter :: (forall f. (MonadPlus f, Traversable f, NFData1 f) => f message -> writerM ()) -> LogWriter message writerM

- Control.Eff.Log.Handler: ignoreLogs :: forall message r a. Eff (Logs message : r) a -> Eff r a

- Control.Eff.Log.Handler: instance (Control.DeepSeq.NFData l, Control.Eff.Lift.Lifted m e, Control.Monad.Catch.MonadThrow (Control.Eff.Internal.Eff e)) => Control.Monad.Catch.MonadThrow (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.Logs l : Control.Eff.Log.Handler.LogWriterReader l m : e))

- Control.Eff.Log.Handler: instance (Control.DeepSeq.NFData l, GHC.Base.Applicative m, Control.Eff.Lift.Lifted m e, Control.Monad.Catch.MonadCatch (Control.Eff.Internal.Eff e)) => Control.Monad.Catch.MonadCatch (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.Logs l : Control.Eff.Log.Handler.LogWriterReader l m : e))

- Control.Eff.Log.Handler: instance (Control.DeepSeq.NFData l, GHC.Base.Applicative m, Control.Eff.Lift.Lifted m e, Control.Monad.Catch.MonadMask (Control.Eff.Internal.Eff e)) => Control.Monad.Catch.MonadMask (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.Logs l : Control.Eff.Log.Handler.LogWriterReader l m : e))

- Control.Eff.Log.Handler: instance (Control.Monad.Base.MonadBase m m, Control.Eff.Lift.Lifted m r, Control.DeepSeq.NFData l, Control.Monad.Trans.Control.MonadBaseControl m (Control.Eff.Internal.Eff r)) => Control.Monad.Trans.Control.MonadBaseControl m (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.Logs l : Control.Eff.Log.Handler.LogWriterReader l m : r))

- Control.Eff.Log.Handler: instance GHC.Base.Applicative w => Data.Default.Class.Default (Control.Eff.Log.Handler.LogWriter m w)

- Control.Eff.Log.Handler: logMsgs :: (Traversable f, MonadPlus f, NFData1 f, NFData (f m), NFData m, Member (Logs m) e) => f m -> Eff e ()

- Control.Eff.Log.Handler: mapLogMessages :: forall m r b. (NFData m, Member (Logs m) r) => (m -> m) -> Eff r b -> Eff r b

- Control.Eff.Log.Handler: multiMessageLogWriter :: Applicative writerM => (((message -> writerM ()) -> writerM ()) -> writerM ()) -> LogWriter message writerM

- Control.Eff.Log.Handler: singleMessageLogWriter :: Applicative writerM => (message -> writerM ()) -> LogWriter message writerM

- Control.Eff.Log.Handler: traceLogs :: forall message r a. (message -> String) -> Eff (Logs message : r) a -> Eff r a

- Control.Eff.Log.Handler: traverseLogMessages :: forall m r h b. (Member (Logs m) r, Monad h, Lifted h r, Member (Reader (LogWriter m h)) r) => (forall f. (MonadPlus f, Traversable f, NFData1 f) => f m -> h (f m)) -> Eff r b -> Eff r b

- Control.Eff.Log.Handler: type HasLogWriter message logWriterMonad effects = (Member (Reader (LogWriter message logWriterMonad)) effects, Member (Logs message) effects, NFData message, Monad logWriterMonad, Lifted logWriterMonad effects)

- Control.Eff.Log.Handler: type LogWriterReader message writerM = Reader (LogWriter message writerM)

- Control.Eff.Log.Handler: writeAllLogMessages :: (NFData1 f, MonadPlus f, Traversable f, Applicative writerM) => LogWriter message writerM -> f message -> writerM ()

- Control.Eff.Log.Handler: writeLogs :: forall message writerM r a. (Applicative writerM, Lifted writerM r, NFData message) => LogWriter message writerM -> Eff (Logs message : (Reader (LogWriter message writerM) : r)) a -> Eff r a

- Control.Eff.Log.Message: LogMessage :: Facility -> Severity -> Maybe UTCTime -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> [StructuredDataElement] -> Maybe ThreadId -> Maybe SrcLoc -> String -> Int -> LogMessage

- Control.Eff.Log.Message: [_lmAppname] :: LogMessage -> Maybe String

- Control.Eff.Log.Message: [_lmDistance] :: LogMessage -> Int

- Control.Eff.Log.Message: dropDistantLogMessages :: HasLogging m r => Int -> Eff r a -> Eff r a

- Control.Eff.Log.Message: increaseLogMessageDistance :: (HasCallStack, HasLogWriter LogMessage h e) => Eff e a -> Eff e a

- Control.Eff.Log.Message: ioLogMessageHandler :: (HasCallStack, Lifted IO e) => LogWriter String IO -> Eff (Logs LogMessage : (LogWriterReader LogMessage IO : e)) a -> Eff e a

- Control.Eff.Log.Message: ioLogMessageWriter :: HasCallStack => LogWriter String IO -> LogWriter LogMessage IO

- Control.Eff.Log.Message: lmAppname :: Lens' LogMessage (Maybe String)

- Control.Eff.Log.Message: lmDistance :: Lens' LogMessage Int

- Control.Eff.Log.Message: logAlert :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()

- Control.Eff.Log.Message: logCritical :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()

- Control.Eff.Log.Message: logDebug :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()

- Control.Eff.Log.Message: logEmergency :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()

- Control.Eff.Log.Message: logError :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()

- Control.Eff.Log.Message: logInfo :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()

- Control.Eff.Log.Message: logNotice :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()

- Control.Eff.Log.Message: logWarning :: (HasCallStack, Member (Logs LogMessage) e) => String -> Eff e ()

- Control.Eff.Log.Message: logWithSeverity :: (HasCallStack, Member (Logs LogMessage) e) => Severity -> String -> Eff e ()

- Control.Eff.Log.Message: traceLogMessageWriter :: Monad m => LogWriter LogMessage m

- Control.Eff.Log.Message: type HasLogging writerM effect = (HasLogWriter LogMessage writerM effect)

+ Control.Eff.Concurrent: defaultMainWithLogWriter :: HasCallStack => LogWriter IO -> Eff InterruptableProcEff () -> IO ()

+ Control.Eff.Concurrent.Process.ForkIOScheduler: defaultMainWithLogWriter :: HasCallStack => LogWriter IO -> Eff InterruptableProcEff () -> IO ()

+ Control.Eff.Log: exampleAsyncLogging :: IO ()

+ Control.Eff.Log: exampleLogCapture :: IO ()

+ Control.Eff.Log: exampleLogPredicate :: IO Int

+ Control.Eff.Log: exampleLogging :: IO ()

+ Control.Eff.Log: exampleWithLogging :: IO ()

+ Control.Eff.Log: exampleWithSomeLogging :: ()

+ Control.Eff.Log.Channel: withAsyncLogging :: (LogsTo IO e, Lifted IO e, MonadBaseControl IO (Eff e), Integral len) => len -> LogWriter IO -> Eff e a -> Eff e a

+ Control.Eff.Log.Handler: addLogWriter :: forall h e a. (HasCallStack, LogsTo h e, Monad h) => LogWriter h -> Eff e a -> Eff e a

+ Control.Eff.Log.Handler: askLogPredicate :: forall e. Member Logs e => Eff e LogPredicate

+ Control.Eff.Log.Handler: censorLogs :: LogsTo h e => (LogMessage -> LogMessage) -> Eff e a -> Eff e a

+ Control.Eff.Log.Handler: censorLogsM :: (LogsTo h e, Monad h) => (LogMessage -> h LogMessage) -> Eff e a -> Eff e a

+ Control.Eff.Log.Handler: data LogWriterReader h v

+ Control.Eff.Log.Handler: excludeLogMessages :: forall e a. Member Logs e => LogPredicate -> Eff e a -> Eff e a

+ Control.Eff.Log.Handler: includeLogMessages :: forall e a. Member Logs e => LogPredicate -> Eff e a -> Eff e a

+ Control.Eff.Log.Handler: instance (Control.Eff.Internal.LiftedBase m e, Control.Monad.Catch.MonadThrow (Control.Eff.Internal.Eff e)) => Control.Monad.Catch.MonadThrow (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.LogWriterReader h : e))

+ Control.Eff.Log.Handler: instance (Control.Monad.Base.MonadBase m m, Control.Eff.Internal.LiftedBase m e, Control.Eff.Log.Writer.SupportsLogger m (Control.Eff.Log.Handler.Logs : e), Data.OpenUnion.SetMember Control.Eff.Log.Handler.LogWriterReader (Control.Eff.Log.Handler.LogWriterReader m) (Control.Eff.Log.Handler.Logs : e)) => Control.Monad.Trans.Control.MonadBaseControl m (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.Logs : e))

+ Control.Eff.Log.Handler: instance (Control.Monad.Base.MonadBase m m, Control.Eff.Internal.LiftedBase m r) => Control.Monad.Trans.Control.MonadBaseControl m (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.LogWriterReader h : r))

+ Control.Eff.Log.Handler: instance (GHC.Base.Applicative m, Control.Eff.Internal.LiftedBase m e, Control.Monad.Catch.MonadCatch (Control.Eff.Internal.Eff e)) => Control.Monad.Catch.MonadCatch (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.LogWriterReader h : e))

+ Control.Eff.Log.Handler: instance (GHC.Base.Applicative m, Control.Eff.Internal.LiftedBase m e, Control.Monad.Catch.MonadCatch (Control.Eff.Internal.Eff e), Control.Eff.Log.Writer.SupportsLogger m (Control.Eff.Log.Handler.Logs : e), Data.OpenUnion.SetMember Control.Eff.Log.Handler.LogWriterReader (Control.Eff.Log.Handler.LogWriterReader m) (Control.Eff.Log.Handler.Logs : e)) => Control.Monad.Catch.MonadCatch (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.Logs : e))

+ Control.Eff.Log.Handler: instance (GHC.Base.Applicative m, Control.Eff.Internal.LiftedBase m e, Control.Monad.Catch.MonadMask (Control.Eff.Internal.Eff e)) => Control.Monad.Catch.MonadMask (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.LogWriterReader h : e))

+ Control.Eff.Log.Handler: instance (GHC.Base.Applicative m, Control.Eff.Internal.LiftedBase m e, Control.Monad.Catch.MonadMask (Control.Eff.Internal.Eff e), Control.Eff.Log.Writer.SupportsLogger m (Control.Eff.Log.Handler.Logs : e), Data.OpenUnion.SetMember Control.Eff.Log.Handler.LogWriterReader (Control.Eff.Log.Handler.LogWriterReader m) (Control.Eff.Log.Handler.Logs : e)) => Control.Monad.Catch.MonadMask (Control.Eff.Internal.Eff (Control.Eff.Log.Handler.Logs : e))

+ Control.Eff.Log.Handler: instance Control.Eff.Internal.Handle (Control.Eff.Log.Handler.LogWriterReader h) e a (Control.Eff.Log.Writer.LogWriter h -> k)

+ Control.Eff.Log.Handler: instance Control.Eff.Internal.Handle Control.Eff.Log.Handler.Logs e a (Control.Eff.Log.Message.LogPredicate -> k)

+ Control.Eff.Log.Handler: interceptLogMessages :: forall r b. Member Logs r => (LogMessage -> Eff r LogMessage) -> Eff r b -> Eff r b

+ Control.Eff.Log.Handler: logAlert :: forall e. (HasCallStack, Member Logs e) => String -> Eff e ()

+ Control.Eff.Log.Handler: logCritical :: forall e. (HasCallStack, Member Logs e) => String -> Eff e ()

+ Control.Eff.Log.Handler: logDebug :: forall e. (HasCallStack, Member Logs e) => String -> Eff e ()

+ Control.Eff.Log.Handler: logEmergency :: forall e. (HasCallStack, Member Logs e) => String -> Eff e ()

+ Control.Eff.Log.Handler: logError :: forall e. (HasCallStack, Member Logs e) => String -> Eff e ()

+ Control.Eff.Log.Handler: logInfo :: forall e. (HasCallStack, Member Logs e) => String -> Eff e ()

+ Control.Eff.Log.Handler: logNotice :: forall e. (HasCallStack, Member Logs e) => String -> Eff e ()

+ Control.Eff.Log.Handler: logWarning :: forall e. (HasCallStack, Member Logs e) => String -> Eff e ()

+ Control.Eff.Log.Handler: logWithSeverity :: forall e. (HasCallStack, Member Logs e) => Severity -> String -> Eff e ()

+ Control.Eff.Log.Handler: modifyLogPredicate :: forall e b. (Member Logs e, HasCallStack) => (LogPredicate -> LogPredicate) -> Eff e b -> Eff e b

+ Control.Eff.Log.Handler: modifyLogWriter :: forall h e a. LogsTo h e => (LogWriter h -> LogWriter h) -> Eff e a -> Eff e a

+ Control.Eff.Log.Handler: respondToLogMessage :: forall r b. Member Logs r => (LogMessage -> Eff r ()) -> Eff r b -> Eff r b

+ Control.Eff.Log.Handler: runLogWriterReader :: LogWriter h -> Eff (LogWriterReader h : e) a -> Eff e a

+ Control.Eff.Log.Handler: setLogPredicate :: forall r b. (Member Logs r, HasCallStack) => LogPredicate -> Eff r b -> Eff r b

+ Control.Eff.Log.Handler: setLogWriter :: forall h e a. LogsTo h e => LogWriter h -> Eff e a -> Eff e a

+ Control.Eff.Log.Handler: type LoggingAndIo = '[Logs, LogWriterReader IO, Lift IO]

+ Control.Eff.Log.Handler: type LogsTo h e = (Member Logs e, SupportsLogger h e, SetMember LogWriterReader (LogWriterReader h) e)

+ Control.Eff.Log.Handler: withConsoleLogging :: SetMember Lift (Lift IO) e => String -> Facility -> LogPredicate -> Eff (Logs : (LogWriterReader IO : e)) a -> Eff e a

+ Control.Eff.Log.Handler: withIoLogging :: SetMember Lift (Lift IO) e => LogWriter IO -> String -> Facility -> LogPredicate -> Eff (Logs : (LogWriterReader IO : e)) a -> Eff e a

+ Control.Eff.Log.Handler: withLogFileAppender :: (Lifted IO e, LogsTo IO e, MonadBaseControl IO (Eff e)) => FilePath -> Eff e b -> Eff e b

+ Control.Eff.Log.Handler: withLogging :: forall h e a. (Applicative h, LogsTo h (Logs : (LogWriterReader h : e))) => LogWriter h -> Eff (Logs : (LogWriterReader h : e)) a -> Eff e a

+ Control.Eff.Log.Handler: withSomeLogging :: forall h e a. (Applicative h, LogsTo h (Logs : (LogWriterReader h : e))) => Eff (Logs : (LogWriterReader h : e)) a -> Eff e a

+ Control.Eff.Log.Message: MkLogMessage :: !Facility -> !Severity -> !Maybe UTCTime -> !Maybe String -> !Maybe String -> !Maybe String -> !Maybe String -> ![StructuredDataElement] -> !Maybe ThreadId -> !Maybe SrcLoc -> !String -> LogMessage

+ Control.Eff.Log.Message: MkSdParameter :: !String -> !String -> SdParameter

+ Control.Eff.Log.Message: [_lmAppName] :: LogMessage -> !Maybe String

+ Control.Eff.Log.Message: allLogMessages :: LogPredicate

+ Control.Eff.Log.Message: class ToLogMessage a

+ Control.Eff.Log.Message: data SdParameter

+ Control.Eff.Log.Message: discriminateByAppName :: String -> LogPredicate -> LogPredicate -> LogPredicate

+ Control.Eff.Log.Message: instance Control.Eff.Log.Message.ToLogMessage Control.Eff.Log.Message.LogMessage

+ Control.Eff.Log.Message: instance Control.Eff.Log.Message.ToLogMessage GHC.Base.String

+ Control.Eff.Log.Message: instance GHC.Show.Show Control.Eff.Log.Message.LogMessage

+ Control.Eff.Log.Message: lmAppName :: Functor f => (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage

+ Control.Eff.Log.Message: lmMessageStartsWith :: String -> LogPredicate

+ Control.Eff.Log.Message: lmSeverityIs :: Severity -> LogPredicate

+ Control.Eff.Log.Message: lmSeverityIsAtLeast :: Severity -> LogPredicate

+ Control.Eff.Log.Message: noLogMessages :: LogPredicate

+ Control.Eff.Log.Message: prefixLogMessagesWith :: String -> LogMessage -> LogMessage

+ Control.Eff.Log.Message: sdName :: String -> String

+ Control.Eff.Log.Message: sdParamValue :: String -> String

+ Control.Eff.Log.Message: setLogMessageHostname :: LogMessage -> IO LogMessage

+ Control.Eff.Log.Message: toLogMessage :: ToLogMessage a => a -> LogMessage

+ Control.Eff.Log.Message: type LogPredicate = LogMessage -> Bool

+ Control.Eff.Log.Writer: MkCaptureLogs :: Eff '[CapturedLogsWriter] a -> CaptureLogs a

+ Control.Eff.Log.Writer: MkLogWriter :: (LogMessage -> writerM ()) -> LogWriter writerM

+ Control.Eff.Log.Writer: MkPureLogWriter :: Identity a -> PureLogWriter a

+ Control.Eff.Log.Writer: [runLogWriter] :: LogWriter writerM -> LogMessage -> writerM ()

+ Control.Eff.Log.Writer: [runPureLogWriter] :: PureLogWriter a -> Identity a

+ Control.Eff.Log.Writer: [unCaptureLogs] :: CaptureLogs a -> Eff '[CapturedLogsWriter] a

+ Control.Eff.Log.Writer: class SupportsLogger h e

+ Control.Eff.Log.Writer: consoleLogWriter :: LogWriter IO

+ Control.Eff.Log.Writer: debugTraceLogWriter :: Monad h => LogWriter h

+ Control.Eff.Log.Writer: defaultIoLogWriter :: String -> Facility -> LogWriter IO -> LogWriter IO

+ Control.Eff.Log.Writer: filteringLogWriter :: Monad e => LogPredicate -> LogWriter e -> LogWriter e

+ Control.Eff.Log.Writer: instance Control.Eff.Internal.Lifted GHC.Types.IO e => Control.Eff.Log.Writer.SupportsLogger GHC.Types.IO e

+ Control.Eff.Log.Writer: instance Control.Eff.Log.Writer.SupportsLogger Control.Eff.Log.Writer.PureLogWriter e

+ Control.Eff.Log.Writer: instance Data.OpenUnion.Member Control.Eff.Log.Writer.CapturedLogsWriter e => Control.Eff.Log.Writer.SupportsLogger Control.Eff.Log.Writer.CaptureLogs e

+ Control.Eff.Log.Writer: instance GHC.Base.Applicative Control.Eff.Log.Writer.CaptureLogs

+ Control.Eff.Log.Writer: instance GHC.Base.Applicative Control.Eff.Log.Writer.PureLogWriter

+ Control.Eff.Log.Writer: instance GHC.Base.Applicative w => Data.Default.Class.Default (Control.Eff.Log.Writer.LogWriter w)

+ Control.Eff.Log.Writer: instance GHC.Base.Functor Control.Eff.Log.Writer.CaptureLogs

+ Control.Eff.Log.Writer: instance GHC.Base.Functor Control.Eff.Log.Writer.PureLogWriter

+ Control.Eff.Log.Writer: instance GHC.Base.Monad Control.Eff.Log.Writer.CaptureLogs

+ Control.Eff.Log.Writer: instance GHC.Base.Monad Control.Eff.Log.Writer.PureLogWriter

+ Control.Eff.Log.Writer: ioHandleLogWriter :: HasCallStack => Handle -> LogWriter IO

+ Control.Eff.Log.Writer: ioLogWriter :: HasCallStack => (LogMessage -> IO ()) -> LogWriter IO

+ Control.Eff.Log.Writer: liftLogWriter :: SupportsLogger h e => LogWriter h -> LogMessage -> Eff e ()

+ Control.Eff.Log.Writer: listLogWriter :: LogWriter CaptureLogs

+ Control.Eff.Log.Writer: mappingLogWriter :: (LogMessage -> LogMessage) -> LogWriter e -> LogWriter e

+ Control.Eff.Log.Writer: mappingLogWriterM :: Monad e => (LogMessage -> e LogMessage) -> LogWriter e -> LogWriter e

+ Control.Eff.Log.Writer: newtype CaptureLogs a

+ Control.Eff.Log.Writer: newtype LogWriter writerM

+ Control.Eff.Log.Writer: newtype PureLogWriter a

+ Control.Eff.Log.Writer: noOpLogWriter :: Applicative m => LogWriter m

+ Control.Eff.Log.Writer: runCapturedLogsWriter :: Eff (CapturedLogsWriter : e) a -> Eff e (a, [LogMessage])

+ Control.Eff.Log.Writer: type CapturedLogsWriter = Writer LogMessage

- Control.Eff.Concurrent: defaultMainSingleThreaded :: HasCallStack => Eff (InterruptableProcess '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO]) () -> IO ()

+ Control.Eff.Concurrent: defaultMainSingleThreaded :: HasCallStack => Eff (InterruptableProcess LoggingAndIo) () -> IO ()

- Control.Eff.Concurrent: flushObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, HasLogging IO r) => Eff r [o]

+ Control.Eff.Concurrent: flushObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, Member Logs r) => Eff r [o]

- Control.Eff.Concurrent: fromServer :: forall api_a17Ha api_a17QA. Iso (Server api_a17Ha) (Server api_a17QA) ProcessId ProcessId

+ Control.Eff.Concurrent: fromServer :: forall api_aSTl api_aT2L. Iso (Server api_aSTl) (Server api_aT2L) ProcessId ProcessId

- Control.Eff.Concurrent: logInterrupts :: (HasCallStack, '[Interrupts, Logs LogMessage] <:: r) => Eff r () -> Eff r ()

+ Control.Eff.Concurrent: logInterrupts :: forall r. (Member Logs r, HasCallStack, Member Interrupts r) => Eff r () -> Eff r ()

- Control.Eff.Concurrent: logProcessExit :: (HasCallStack, Member (Logs LogMessage) e) => ExitReason x -> Eff e ()

+ Control.Eff.Concurrent: logProcessExit :: forall e x. (Member Logs e, HasCallStack) => ExitReason x -> Eff e ()

- Control.Eff.Concurrent: logUnhandledMessages :: forall eff. (Member (Logs LogMessage) eff, HasCallStack) => MessageCallback '[] eff

+ Control.Eff.Concurrent: logUnhandledMessages :: forall eff. (Member Logs eff, HasCallStack) => MessageCallback '[] eff

- Control.Eff.Concurrent: readObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, HasLogging IO r) => Eff r o

+ Control.Eff.Concurrent: readObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, Member Logs r) => Eff r o

- Control.Eff.Concurrent: schedule :: (HasLogging IO SchedulerIO, HasCallStack) => Eff InterruptableProcEff () -> Eff LoggingAndIO ()

+ Control.Eff.Concurrent: schedule :: HasCallStack => Eff InterruptableProcEff () -> Eff LoggingAndIo ()

- Control.Eff.Concurrent: schedulePure :: Eff (InterruptableProcess '[Logs LogMessage]) a -> Either (ExitReason 'NoRecovery) a

+ Control.Eff.Concurrent: schedulePure :: Eff (InterruptableProcess '[Logs, LogWriterReader PureLogWriter]) a -> Either (ExitReason 'NoRecovery) a

- Control.Eff.Concurrent: spawnLinkObservationQueueWriter :: forall o q. (Typeable o, Show o, HasLogging IO q, Lifted IO q, HasCallStack) => ObservationQueue o -> Eff (InterruptableProcess q) (Observer o)

+ Control.Eff.Concurrent: spawnLinkObservationQueueWriter :: forall o q. (Typeable o, Show o, Member Logs q, Lifted IO q, HasCallStack) => ObservationQueue o -> Eff (InterruptableProcess q) (Observer o)

- Control.Eff.Concurrent: tryReadObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, HasLogging IO r) => Eff r (Maybe o)

+ Control.Eff.Concurrent: tryReadObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, Member Logs r) => Eff r (Maybe o)

- Control.Eff.Concurrent: type SchedulerIO = (Reader SchedulerState : LoggingAndIO)

+ Control.Eff.Concurrent: type SchedulerIO = (Reader SchedulerState : LoggingAndIo)

- Control.Eff.Concurrent: withObservationQueue :: forall o b e len. (HasCallStack, Typeable o, Show o, HasLogging IO e, Integral len, Member Interrupts e) => len -> Eff (ObservationQueueReader o : e) b -> Eff e b

+ Control.Eff.Concurrent: withObservationQueue :: forall o b e len. (HasCallStack, Typeable o, Show o, Member Logs e, Lifted IO e, Integral len, Member Interrupts e) => len -> Eff (ObservationQueueReader o : e) b -> Eff e b

- Control.Eff.Concurrent.Api: fromServer :: forall api_a17Ha api_a17QA. Iso (Server api_a17Ha) (Server api_a17QA) ProcessId ProcessId

+ Control.Eff.Concurrent.Api: fromServer :: forall api_aSTl api_aT2L. Iso (Server api_aSTl) (Server api_aT2L) ProcessId ProcessId

- Control.Eff.Concurrent.Api.Observer.Queue: flushObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, HasLogging IO r) => Eff r [o]

+ Control.Eff.Concurrent.Api.Observer.Queue: flushObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, Member Logs r) => Eff r [o]

- Control.Eff.Concurrent.Api.Observer.Queue: readObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, HasLogging IO r) => Eff r o

+ Control.Eff.Concurrent.Api.Observer.Queue: readObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, Member Logs r) => Eff r o

- Control.Eff.Concurrent.Api.Observer.Queue: spawnLinkObservationQueueWriter :: forall o q. (Typeable o, Show o, HasLogging IO q, Lifted IO q, HasCallStack) => ObservationQueue o -> Eff (InterruptableProcess q) (Observer o)

+ Control.Eff.Concurrent.Api.Observer.Queue: spawnLinkObservationQueueWriter :: forall o q. (Typeable o, Show o, Member Logs q, Lifted IO q, HasCallStack) => ObservationQueue o -> Eff (InterruptableProcess q) (Observer o)

- Control.Eff.Concurrent.Api.Observer.Queue: tryReadObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, HasLogging IO r) => Eff r (Maybe o)

+ Control.Eff.Concurrent.Api.Observer.Queue: tryReadObservationQueue :: forall o r. (Member (ObservationQueueReader o) r, HasCallStack, MonadIO (Eff r), Typeable o, Member Logs r) => Eff r (Maybe o)

- Control.Eff.Concurrent.Api.Observer.Queue: withObservationQueue :: forall o b e len. (HasCallStack, Typeable o, Show o, HasLogging IO e, Integral len, Member Interrupts e) => len -> Eff (ObservationQueueReader o : e) b -> Eff e b

+ Control.Eff.Concurrent.Api.Observer.Queue: withObservationQueue :: forall o b e len. (HasCallStack, Typeable o, Show o, Member Logs e, Lifted IO e, Integral len, Member Interrupts e) => len -> Eff (ObservationQueueReader o : e) b -> Eff e b

- Control.Eff.Concurrent.Api.Server: logUnhandledMessages :: forall eff. (Member (Logs LogMessage) eff, HasCallStack) => MessageCallback '[] eff

+ Control.Eff.Concurrent.Api.Server: logUnhandledMessages :: forall eff. (Member Logs eff, HasCallStack) => MessageCallback '[] eff

- Control.Eff.Concurrent.Process: logInterrupts :: (HasCallStack, '[Interrupts, Logs LogMessage] <:: r) => Eff r () -> Eff r ()

+ Control.Eff.Concurrent.Process: logInterrupts :: forall r. (Member Logs r, HasCallStack, Member Interrupts r) => Eff r () -> Eff r ()

- Control.Eff.Concurrent.Process: logProcessExit :: (HasCallStack, Member (Logs LogMessage) e) => ExitReason x -> Eff e ()

+ Control.Eff.Concurrent.Process: logProcessExit :: forall e x. (Member Logs e, HasCallStack) => ExitReason x -> Eff e ()

- Control.Eff.Concurrent.Process.ForkIOScheduler: schedule :: (HasLogging IO SchedulerIO, HasCallStack) => Eff InterruptableProcEff () -> Eff LoggingAndIO ()

+ Control.Eff.Concurrent.Process.ForkIOScheduler: schedule :: HasCallStack => Eff InterruptableProcEff () -> Eff LoggingAndIo ()

- Control.Eff.Concurrent.Process.ForkIOScheduler: type SchedulerIO = (Reader SchedulerState : LoggingAndIO)

+ Control.Eff.Concurrent.Process.ForkIOScheduler: type SchedulerIO = (Reader SchedulerState : LoggingAndIo)

- Control.Eff.Concurrent.Process.SingleThreadedScheduler: defaultMainSingleThreaded :: HasCallStack => Eff (InterruptableProcess '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO]) () -> IO ()

+ Control.Eff.Concurrent.Process.SingleThreadedScheduler: defaultMainSingleThreaded :: HasCallStack => Eff (InterruptableProcess LoggingAndIo) () -> IO ()

- Control.Eff.Concurrent.Process.SingleThreadedScheduler: scheduleIOWithLogging :: NFData l => LogWriter l IO -> Eff (InterruptableProcess '[Logs l, LogWriterReader l IO, Lift IO]) a -> IO (Either (ExitReason 'NoRecovery) a)

+ Control.Eff.Concurrent.Process.SingleThreadedScheduler: scheduleIOWithLogging :: HasCallStack => LogWriter IO -> Eff (InterruptableProcess LoggingAndIo) a -> IO (Either (ExitReason 'NoRecovery) a)

- Control.Eff.Concurrent.Process.SingleThreadedScheduler: schedulePure :: Eff (InterruptableProcess '[Logs LogMessage]) a -> Either (ExitReason 'NoRecovery) a

+ Control.Eff.Concurrent.Process.SingleThreadedScheduler: schedulePure :: Eff (InterruptableProcess '[Logs, LogWriterReader PureLogWriter]) a -> Either (ExitReason 'NoRecovery) a

- Control.Eff.Log.Handler: askLogWriter :: forall m h r. Member (Reader (LogWriter m h)) r => Eff r (LogWriter m h)

+ Control.Eff.Log.Handler: askLogWriter :: SetMember LogWriterReader (LogWriterReader h) e => Eff e (LogWriter h)

- Control.Eff.Log.Handler: data Logs m v

+ Control.Eff.Log.Handler: data Logs v

- Control.Eff.Log.Handler: logMsg :: (NFData m, Member (Logs m) e) => m -> Eff e ()

+ Control.Eff.Log.Handler: logMsg :: forall e m. (HasCallStack, Member Logs e, ToLogMessage m) => m -> Eff e ()

- Control.Eff.Log.Handler: runLogs :: forall m h e b. (Applicative h, Lifted h e, Member (LogWriterReader m h) e, NFData m) => Eff (Logs m : e) b -> Eff e b

+ Control.Eff.Log.Handler: runLogs :: forall h e b. (LogsTo h (Logs : e), SupportsLogger h (Logs : e)) => LogPredicate -> Eff (Logs : e) b -> Eff e b

- Control.Eff.Log.Message: SdElement :: String -> [SdParameter] -> StructuredDataElement

+ Control.Eff.Log.Message: SdElement :: !String -> ![SdParameter] -> StructuredDataElement

- Control.Eff.Log.Message: [_lmFacility] :: LogMessage -> Facility

+ Control.Eff.Log.Message: [_lmFacility] :: LogMessage -> !Facility

- Control.Eff.Log.Message: [_lmHostname] :: LogMessage -> Maybe String

+ Control.Eff.Log.Message: [_lmHostname] :: LogMessage -> !Maybe String

- Control.Eff.Log.Message: [_lmMessageId] :: LogMessage -> Maybe String

+ Control.Eff.Log.Message: [_lmMessageId] :: LogMessage -> !Maybe String

- Control.Eff.Log.Message: [_lmMessage] :: LogMessage -> String

+ Control.Eff.Log.Message: [_lmMessage] :: LogMessage -> !String

- Control.Eff.Log.Message: [_lmProcessId] :: LogMessage -> Maybe String

+ Control.Eff.Log.Message: [_lmProcessId] :: LogMessage -> !Maybe String

- Control.Eff.Log.Message: [_lmSeverity] :: LogMessage -> Severity

+ Control.Eff.Log.Message: [_lmSeverity] :: LogMessage -> !Severity

- Control.Eff.Log.Message: [_lmSrcLoc] :: LogMessage -> Maybe SrcLoc

+ Control.Eff.Log.Message: [_lmSrcLoc] :: LogMessage -> !Maybe SrcLoc

- Control.Eff.Log.Message: [_lmStructuredData] :: LogMessage -> [StructuredDataElement]

+ Control.Eff.Log.Message: [_lmStructuredData] :: LogMessage -> ![StructuredDataElement]

- Control.Eff.Log.Message: [_lmThreadId] :: LogMessage -> Maybe ThreadId

+ Control.Eff.Log.Message: [_lmThreadId] :: LogMessage -> !Maybe ThreadId

- Control.Eff.Log.Message: [_lmTimestamp] :: LogMessage -> Maybe UTCTime

+ Control.Eff.Log.Message: [_lmTimestamp] :: LogMessage -> !Maybe UTCTime

- Control.Eff.Log.Message: [_sdElementId] :: StructuredDataElement -> String

+ Control.Eff.Log.Message: [_sdElementId] :: StructuredDataElement -> !String

- Control.Eff.Log.Message: [_sdElementParameters] :: StructuredDataElement -> [SdParameter]

+ Control.Eff.Log.Message: [_sdElementParameters] :: StructuredDataElement -> ![SdParameter]

- Control.Eff.Log.Message: lmFacility :: Lens' LogMessage Facility

+ Control.Eff.Log.Message: lmFacility :: Functor f => (Facility -> f Facility) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: lmHostname :: Lens' LogMessage (Maybe String)

+ Control.Eff.Log.Message: lmHostname :: Functor f => (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: lmMessage :: Lens' LogMessage String

+ Control.Eff.Log.Message: lmMessage :: Functor f => (String -> f String) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: lmMessageId :: Lens' LogMessage (Maybe String)

+ Control.Eff.Log.Message: lmMessageId :: Functor f => (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: lmProcessId :: Lens' LogMessage (Maybe String)

+ Control.Eff.Log.Message: lmProcessId :: Functor f => (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: lmSeverity :: Lens' LogMessage Severity

+ Control.Eff.Log.Message: lmSeverity :: Functor f => (Severity -> f Severity) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: lmSrcLoc :: Lens' LogMessage (Maybe SrcLoc)

+ Control.Eff.Log.Message: lmSrcLoc :: Functor f => (Maybe SrcLoc -> f (Maybe SrcLoc)) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: lmStructuredData :: Lens' LogMessage [StructuredDataElement]

+ Control.Eff.Log.Message: lmStructuredData :: Functor f => ([StructuredDataElement] -> f [StructuredDataElement]) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: lmThreadId :: Lens' LogMessage (Maybe ThreadId)

+ Control.Eff.Log.Message: lmThreadId :: Functor f => (Maybe ThreadId -> f (Maybe ThreadId)) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: lmTimestamp :: Lens' LogMessage (Maybe UTCTime)

+ Control.Eff.Log.Message: lmTimestamp :: Functor f => (Maybe UTCTime -> f (Maybe UTCTime)) -> LogMessage -> f LogMessage

- Control.Eff.Log.Message: sdElementId :: Lens' StructuredDataElement String

+ Control.Eff.Log.Message: sdElementId :: Functor f => (String -> f String) -> StructuredDataElement -> f StructuredDataElement

- Control.Eff.Log.Message: sdElementParameters :: Lens' StructuredDataElement [SdParameter]

+ Control.Eff.Log.Message: sdElementParameters :: Functor f => ([SdParameter] -> f [SdParameter]) -> StructuredDataElement -> f StructuredDataElement

- Control.Eff.Log.Message: setLogMessageThreadId :: MonadIO m => LogMessage -> m LogMessage

+ Control.Eff.Log.Message: setLogMessageThreadId :: LogMessage -> IO LogMessage

- Control.Eff.Log.Message: setLogMessageTimestamp :: MonadIO m => LogMessage -> m LogMessage

+ Control.Eff.Log.Message: setLogMessageTimestamp :: LogMessage -> IO LogMessage

Files

.travis.yml +1/−1
default.nix +2/−0
examples/example-1/Main.hs +3/−3
examples/example-2/Main.hs +3/−4
examples/example-3/Main.hs +19/−37
examples/example-4/Main.hs +10/−8
extensible-effects-concurrent.cabal +22/−15
extensible-effects-concurrent.nix +13/−0
release.nix +2/−0
shell.nix +2/−0
src/Control/Eff/Concurrent.hs +1/−3
src/Control/Eff/Concurrent/Api/Observer.hs +8/−7
src/Control/Eff/Concurrent/Api/Observer/Queue.hs +15/−14
src/Control/Eff/Concurrent/Api/Server.hs +13/−13
src/Control/Eff/Concurrent/Process.hs +37/−38
src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs +439/−556
src/Control/Eff/Concurrent/Process/Interactive.hs +0/−1
src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs +218/−255
src/Control/Eff/Concurrent/Process/Timer.hs +0/−1
src/Control/Eff/ExceptionExtra.hs +1/−2
src/Control/Eff/Log.hs +205/−4
src/Control/Eff/Log/Channel.hs +68/−81
src/Control/Eff/Log/Handler.hs +644/−342
src/Control/Eff/Log/Message.hs +441/−324
src/Control/Eff/Log/Writer.hs +169/−0
stack.nightly-2018-05-29.yaml +0/−68
stack.yaml +2/−2
test/Common.hs +29/−55
test/ForkIOScheduler.hs +17/−46
test/Interactive.hs +0/−1
test/LoggingTests.hs +33/−28
test/LoopTests.hs +4/−18
test/ProcessBehaviourTestCases.hs +40/−32
with-hoogle.nix +22/−0

.travis.yml view

@@ -7,7 +7,7 @@     sources:     - hvr-ghc     packages:-    - ghc-8.2.2+    - ghc-8.6.3  before_install:  - mkdir -p ~/.local/bin

+ default.nix view

@@ -0,0 +1,2 @@+{ pkgs ? (import <nixpkgs> {}) }:+pkgs.callPackage ./extensible-effects-concurrent.nix {}

examples/example-1/Main.hs view

@@ -3,7 +3,6 @@  import           GHC.Stack import           Control.Eff-import           Control.Eff.Lift import           Control.Monad import           Data.Dynamic import           Control.Eff.Concurrent@@ -32,7 +31,7 @@ mainProcessSpawnsAChildAndReturns :: HasCallStack => Eff (InterruptableProcess q) () mainProcessSpawnsAChildAndReturns = void (spawn (void receiveAnyMessage)) -example:: ( HasCallStack, HasLogging IO q) => Eff (InterruptableProcess q) ()+example:: ( HasCallStack, Member Logs q, Lifted IO q) => Eff (InterruptableProcess q) () example = do   me <- self   logInfo ("I am " ++ show me)@@ -64,7 +63,8 @@ testServerLoop   :: forall q    . ( HasCallStack-     , HasLogging IO q+     , Member Logs q+     , Lifted IO q      )   => Eff (InterruptableProcess q) (Server TestApi) testServerLoop = spawnApiServer

examples/example-2/Main.hs view

@@ -3,7 +3,6 @@  import           Data.Dynamic import           Control.Eff-import           Control.Eff.Lift import           Control.Eff.Concurrent import           Control.Eff.State.Strict import           Control.Monad@@ -23,7 +22,7 @@   deriving Typeable  counterExample-  :: (Member (Logs LogMessage) q, Lifted IO q)+  :: (Member Logs q, Lifted IO q)   => Eff (InterruptableProcess q) () counterExample = do   (c, (co, (_sdp, cp))) <- spawnCounter@@ -62,7 +61,7 @@   deriving (Show, Typeable)  spawnCounter-  :: (Member (Logs LogMessage) q)+  :: (Member Logs q)   => Eff        (InterruptableProcess q)        ( Server Counter@@ -127,7 +126,7 @@ deriving instance Show (Api Counter x)  logCounterObservations-  :: (Member (Logs LogMessage) q)+  :: (Member Logs q)   => Eff (InterruptableProcess q) (Observer CounterChanged) logCounterObservations = do   svr <- spawnApiServer

examples/example-3/Main.hs view

@@ -1,44 +1,26 @@ module Main where -import           Control.Concurrent-import           Control.Eff.Lift+import           Control.Eff import           Control.Eff.Log-import           Control.Exception             as IOException-import           System.Directory-import           System.FilePath-import           System.IO+import           Control.Lens  main :: IO ()-main = withAsyncLogChannel-  (1000 :: Int)-  (ioLogMessageWriter-    (fileAppender "extensible-effects-concurrent-example-3.log")-  )-  (handleLoggingAndIO-    (do-      logInfo "test 1"-      lift (threadDelay 1000000)-      logDebug "test 2"-      lift (threadDelay 1000000)-      logCritical "test 3"-      lift (threadDelay 1000000)-    )-  )+main =+  runLift+  $  withSomeLogging @IO+  $  withLogFileAppender  "extensible-effects-concurrent-example-3.log"+  $  addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("traced: "++)) debugTraceLogWriter))+  $  modifyLogWriter (defaultIoLogWriter "example-3" local0)+  $  addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("traced without timestamp: "++)) debugTraceLogWriter))+  $  do+        logEmergency "test emergencySeverity 1"+        logCritical "test criticalSeverity 2"+        logAlert "test alertSeverity 3"+        logError "test errorSeverity 4"+        logWarning "test warningSeverity 5"+        logInfo "test informationalSeverity 6"+        logDebug "test debugSeverity 7" -fileAppender :: FilePath -> LogWriter String IO-fileAppender fnIn = multiMessageLogWriter-  (\writeLogMessageWith -> bracket-    (do-      fnCanon <- canonicalizePath fnIn-      createDirectoryIfMissing True (takeDirectory fnCanon)-      h <- openFile fnCanon AppendMode-      hSetBuffering h (BlockBuffering (Just 1024))-      return h-    )-    (\h -> IOException.try @SomeException (hFlush h) >> hClose h)-    (writeLogMessageWith . hPutStrLn)-  ) -fileAppenderSimple :: FilePath -> LogWriter String IO-fileAppenderSimple fnIn =-  singleMessageLogWriter (\msg -> withFile fnIn AppendMode (`hPutStrLn` msg))+testPred :: LogPredicate+testPred = view (lmSeverity . to (<= errorSeverity))

examples/example-4/Main.hs view

@@ -1,23 +1,25 @@ module Main where  import           Control.Eff-import           Control.Eff.Lift import           Control.Eff.Concurrent import           Data.Dynamic import           Control.Concurrent import           Control.DeepSeq+import           GHC.Stack (HasCallStack)  main :: IO ()-main = defaultMain-  (do-    lift (threadDelay 100000) -- because of async logging-    firstExample-    lift (threadDelay 100000) -- ... async logging-  )+main =+    defaultMainWithLogWriter+      (defaultIoLogWriter "example-4" local0 consoleLogWriter)+  $ do+       lift (threadDelay 100000) -- because of async logging+       firstExample+       lift (threadDelay 100000) -- ... async logging + newtype WhoAreYou = WhoAreYou ProcessId deriving (Typeable, NFData, Show) -firstExample :: (HasLogging IO q) => Eff (InterruptableProcess q) ()+firstExample :: (HasCallStack, Member Logs q) => Eff (InterruptableProcess q) () firstExample = do   person <- spawn     (do

extensible-effects-concurrent.cabal view

@@ -1,5 +1,6 @@+cabal-version:  2.0 name:           extensible-effects-concurrent-version:        0.18.1+version:        0.19.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@@ -7,12 +8,11 @@ author:         Sven Heyll maintainer:     sven.heyll@gmail.com category:       Concurrency, Control, Effect-tested-with:    GHC==8.2.2, GHC==8.4.3, GHC==8.4.4, GHC==8.6.1+tested-with:    GHC==8.6.4 copyright:      Copyright Sven Heyll license:        BSD3 license-file:   LICENSE build-type:     Simple-cabal-version:  2.0  extra-doc-files:     docs/extensible-effects-concurrent-test-Loop-without-space-leaks.png@@ -20,7 +20,11 @@  extra-source-files:     stack.yaml-    stack.nightly-2018-05-29.yaml+    extensible-effects-concurrent.nix+    default.nix+    shell.nix+    release.nix+    with-hoogle.nix     ChangeLog.md     README.md     brittany.yaml@@ -35,21 +39,23 @@       src   build-depends:       async >= 2.2 && <3,-      base >=4.7 && <5,+      base >= 4.12 && <5,       data-default >= 0.7 && < 0.8,       deepseq >= 1.4 && < 1.5,+      directory,+      hostname,       exceptions >= 0.10 && < 0.11,       safe-exceptions >= 0.1 && < 0.2,       filepath >= 1.4 && < 1.5,       time >= 1.8 && < 1.9,       mtl >= 2.2 && < 2.3,       containers >=0.5.8 && <0.7,-      QuickCheck <2.12,+      QuickCheck,       lens >= 4.14 && < 4.18,       parallel >= 3.2 && < 3.3,       process >= 1.6 && < 1.7,       monad-control >= 1.0 && < 1.1,-      extensible-effects >= 3.1.0.2 && <4,+      extensible-effects >= 5 && < 6,       stm >= 2.4.5 && <2.6,       transformers-base >= 0.4 && < 0.5   autogen-modules: Paths_extensible_effects_concurrent@@ -60,6 +66,7 @@                   Control.Eff.Log.Channel,                   Control.Eff.Log.Handler,                   Control.Eff.Log.Message,+                  Control.Eff.Log.Writer,                   Control.Eff.Concurrent,                   Control.Eff.Concurrent.Api,                   Control.Eff.Concurrent.Api.Client,@@ -113,7 +120,7 @@               , extensible-effects-concurrent               , extensible-effects               , lens-  ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes                       , BangPatterns@@ -141,7 +148,7 @@               , extensible-effects-concurrent               , extensible-effects               , lens-  ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes                       , BangPatterns@@ -171,7 +178,7 @@               , extensible-effects               , filepath               , lens-  ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes                       , BangPatterns@@ -198,7 +205,7 @@               , extensible-effects-concurrent               , extensible-effects               , deepseq-  ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -threaded -fno-full-laziness   default-language: Haskell2010   default-extensions:   AllowAmbiguousTypes                       , BangPatterns@@ -230,19 +237,19 @@               , LoopTests               , ProcessBehaviourTestCases               , SingleThreadedScheduler-  ghc-options: -Wall -threaded -fno-full-laziness -rtsopts -with-rtsopts=-N+  ghc-options: -Wall -threaded -fno-full-laziness   build-depends:                 async-              , base >=4.7 && <5+              , base               , data-default               , extensible-effects-concurrent-              , extensible-effects >= 3.1.0.2 && < 3.2+              , extensible-effects               , tasty               , tasty-discover               , tasty-hunit               , containers               , deepseq-              , QuickCheck <2.12+              , QuickCheck               , lens               , HUnit               , stm

+ extensible-effects-concurrent.nix view

@@ -0,0 +1,13 @@+{ lib, haskellPackages }:+let+  cleanSrc = lib.cleanSourceWith {+    filter = (path: type:+      let base = baseNameOf (toString path);+      in !(lib.hasPrefix ".ghc.environment." base) &&+         !(lib.hasSuffix ".nix" base)+    );+    src = lib.cleanSource ./.;+  };++  in haskellPackages.callCabal2nix+       "extensible-effects-concurrent" cleanSrc {}

+ release.nix view

@@ -0,0 +1,2 @@+{ pkgs ? (import <nixpkgs> {}) }:+pkgs.callPackage ./extensible-effects-concurrent.nix {}

+ shell.nix view

@@ -0,0 +1,2 @@+{ pkgs ? (import <nixpkgs> {}) }:+pkgs.callPackage ./extensible-effects-concurrent.nix {}

src/Control/Eff/Concurrent.hs view

@@ -214,18 +214,16 @@ import           Control.Eff.Concurrent.Process.ForkIOScheduler                                                 ( schedule                                                 , defaultMain-                                                , defaultMainWithLogChannel+                                                , defaultMainWithLogWriter                                                 , ProcEff                                                 , InterruptableProcEff                                                 , SchedulerIO                                                 , HasSchedulerIO-                                                , forkIoScheduler                                                 )  import           Control.Eff.Concurrent.Process.SingleThreadedScheduler                                                 ( schedulePure                                                 , defaultMainSingleThreaded-                                                , singleThreadedIoScheduler                                                 ) import           Control.Eff.Log import           Control.Eff.Loop

src/Control/Eff/Concurrent/Api/Observer.hs view

@@ -79,7 +79,7 @@ registerObserver observer observerRegistry =   cast observerRegistry (RegisterObserver observer) --- | Send the 'forgetObserverMessage'+-- | Send the 'ForgetObserver' message -- -- @since 0.16.0 forgetObserver@@ -109,7 +109,7 @@  -- | Based on the 'Api' instance for 'Observer' this simplified writing -- a callback handler for observations. In order to register to--- and 'ObservationRegistry' use 'toObserver'.+-- and 'ObserverRegistry' use 'toObserver'. -- -- @since 0.16.0 handleObservations@@ -121,7 +121,7 @@     Observed o -> k o   ) --- | Use a 'Server' as an 'Observer' for 'handleObserved'.+-- | Use a 'Server' as an 'Observer' for 'handleObservations'. -- -- @since 0.16.0 toObserver :: Typeable o => Server (Observer o) -> Observer o@@ -148,7 +148,7 @@ data ObserverRegistry o  -- | Api for managing observers. This can be added to any server for any number of different observation types.--- The functions 'manageObservers' and 'handleObserverApi' are used to include observer handling;+-- The functions 'manageObservers' and 'handleObserverRegistration' are used to include observer handling; -- -- @since 0.16.0 data instance Api (ObserverRegistry o) r where@@ -165,7 +165,7 @@  -- ** Api for integrating 'ObserverRegistry' into processes. --- | Provide the implementation for the 'Observerd' Api, this handled 'RegisterObserver' and 'ForgetObserver'+-- | Provide the implementation for the 'ObserverRegistry' Api, this handled 'RegisterObserver' and 'ForgetObserver' -- messages. It also adds the 'ObserverState' constraint to the effect list. -- -- @since 0.16.0@@ -192,8 +192,9 @@   )  --- | Keep track of registered 'Observer's Observers can be added and removed,--- and an 'Observation' can be sent to all registerd observers at once.+-- | Keep track of registered 'Observer's.+--+-- Handle the 'ObserverState' introduced by 'handleObserverRegistration'. -- -- @since 0.16.0 manageObservers :: Eff (ObserverState o ': r) a -> Eff r a

src/Control/Eff/Concurrent/Api/Observer/Queue.hs view

@@ -13,7 +13,6 @@ import           Control.Concurrent.STM import           Control.Eff import           Control.Eff.ExceptionExtra     ( )-import           Control.Eff.Lift import           Control.Eff.Concurrent.Process import           Control.Eff.Log import           Control.Eff.Concurrent.Api.Observer@@ -25,8 +24,8 @@ import           Data.Typeable import           GHC.Stack --- | Contains a 'TBQueue' capturing observations received by 'enqueueObservationsRegistered'--- or 'spawnLinkObservationQueueWriter'.+-- | Contains a 'TBQueue' capturing observations.+-- See 'spawnLinkObservationQueueWriter', 'readObservationQueue'. newtype ObservationQueue a = ObservationQueue (TBQueue a)  -- | A 'Reader' for an 'ObservationQueue'.@@ -44,7 +43,7 @@      , HasCallStack      , MonadIO (Eff r)      , Typeable o-     , HasLogging IO r+     , Member Logs r      )   => Eff r o readObservationQueue = do@@ -60,23 +59,24 @@      , HasCallStack      , MonadIO (Eff r)      , Typeable o-     , HasLogging IO r+     , Member Logs r      )   => Eff r (Maybe o) tryReadObservationQueue = do   ObservationQueue q <- ask @(ObservationQueue o)   liftIO (atomically (tryReadTBQueue q)) --- | Read at once all currently queued observations captured and enqueued in the shared 'TBQueue' by 'spawnLinkObservationQueueWriter'.--- This returns immediately all currently enqueued 'Observation's. For a blocking--- variant use 'readObservationQueue'.+-- | Read at once all currently queued observations captured and enqueued+-- in the shared 'TBQueue' by 'spawnLinkObservationQueueWriter'.+-- This returns immediately all currently enqueued observations.+-- For a blocking variant use 'readObservationQueue'. flushObservationQueue   :: forall o r    . ( Member (ObservationQueueReader o) r      , HasCallStack      , MonadIO (Eff r)      , Typeable o-     , HasLogging IO r+     , Member Logs r      )   => Eff r [o] flushObservationQueue = do@@ -105,7 +105,8 @@    . ( HasCallStack      , Typeable o      , Show o-     , HasLogging IO e+     , Member Logs e+     , Lifted IO e      , Integral len      , Member Interrupts e      )@@ -113,14 +114,14 @@   -> Eff (ObservationQueueReader o ': e) b   -> Eff e b withObservationQueue queueLimit e = do-  q   <- liftIO (newTBQueueIO (fromIntegral queueLimit))+  q   <- lift (newTBQueueIO (fromIntegral queueLimit))   res <- handleInterrupts (return . Left)                           (Right <$> runReader (ObservationQueue q) e)-  rest <- liftIO (atomically (flushTBQueue q))+  rest <- lift (atomically (flushTBQueue q))   unless     (null rest)     (logNotice (logPrefix (Proxy @o) ++ " unread observations: " ++ show rest))-  either (\em -> logError (show em) >> liftIO (throwIO em)) return res+  either (\em -> logError (show em) >> lift (throwIO em)) return res  -- | Spawn a process that can be used as an 'Observer' that enqueues the observations into an --   'ObservationQueue'. See 'withObservationQueue' for an example.@@ -132,7 +133,7 @@ -- @since 0.18.0 spawnLinkObservationQueueWriter   :: forall o q-   . (Typeable o, Show o, HasLogging IO q, Lifted IO q, HasCallStack)+   . (Typeable o, Show o, Member Logs q, Lifted IO q, HasCallStack)   => ObservationQueue o   -> Eff (InterruptableProcess q) (Observer o) spawnLinkObservationQueueWriter (ObservationQueue q) = do

src/Control/Eff/Concurrent/Api/Server.hs view

@@ -12,7 +12,7 @@   -- ** Api Server Callbacks   , CallbackResult(..)   , MessageCallback(..)-  -- ** Callback Smart Contructors+  -- ** Callback Smart Constructors   -- *** Calls and Casts (for 'Api's)   , handleCasts   , handleCalls@@ -124,9 +124,9 @@   -> MessageCallback api serverEff   -> InterruptCallback serverEff   -> Eff (InterruptableProcess eff) (ServerPids api)-spawnApiServerEffectful handleServerInteralEffects scb icb =+spawnApiServerEffectful handleServerInternalEffects scb icb =   toServerPids (Proxy @api)-    <$> spawn (handleServerInteralEffects (apiServerLoop scb icb))+    <$> spawn (handleServerInternalEffects (apiServerLoop scb icb))   -- | /Server/ an 'Api' in a newly spawned process; The caller provides an@@ -145,11 +145,11 @@   -> MessageCallback api serverEff   -> InterruptCallback serverEff   -> Eff (InterruptableProcess eff) (ServerPids api)-spawnLinkApiServerEffectful handleServerInteralEffects scb icb =+spawnLinkApiServerEffectful handleServerInternalEffects scb icb =   toServerPids (Proxy @api)-    <$> spawnLink (handleServerInteralEffects (apiServerLoop scb icb))+    <$> spawnLink (handleServerInternalEffects (apiServerLoop scb icb)) --- | Receive loop for 'Api' 'call's. This starts a receive loop for+-- | Receive loop for 'Api' 'Control.Eff.Concurrent.Api.Client.call's. This starts a receive loop for -- a 'MessageCallback'. It is used behind the scenes by 'spawnLinkApiServerEffectful' -- and 'spawnApiServerEffectful'. --@@ -182,17 +182,16 @@   handleCallbackResult (Right (Left r)) =     intCb r >>= handleCallbackResult . Left --- | A command to the server loop started e.g. by 'server' or 'spawnServerWithEffects'.--- Typically returned by an 'ApiHandler' member to indicate if the server+-- | A command to the server loop started by 'apiServerLoop'.+-- Typically returned by a 'MessageCallback' to indicate if the server -- should continue or stop. -- -- @since 0.13.2 data CallbackResult where   -- | Tell the server to keep the server loop running   AwaitNext :: CallbackResult-  -- | Tell the server to exit, this will make 'serve' stop handling requests without-  -- exitting the process. '_terminateCallback' will be invoked with the given-  -- optional reason.+  -- | Tell the server to exit, this will cause 'apiServerLoop' to stop handling requests without+  -- exiting the process.   StopServer :: InterruptReason -> CallbackResult   --  SendReply :: reply -> CallbackResult () -> CallbackResult (reply -> Eff eff ())   deriving ( Typeable )@@ -378,7 +377,7 @@   -> MessageCallback '[] eff handleProcessDowns k = MessageCallback selectMessage (k . downReference) --- | Compose two 'Api's to a type-leve pair of them.+-- | Compose two 'Api's to a type-level pair of them. -- -- > handleCalls api1calls ^: handleCalls api2calls ^: --@@ -424,11 +423,12 @@ -- @since 0.13.2 logUnhandledMessages   :: forall eff-   . (Member (Logs LogMessage) eff, HasCallStack)+   . (Member Logs eff, HasCallStack)   => MessageCallback '[] eff logUnhandledMessages = MessageCallback selectAnyMessageLazy $ \msg -> do   logWarning ("ignoring unhandled message " ++ show msg)   return AwaitNext+  -- | Helper type class for the return values of 'spawnApiServer' et al. --

src/Control/Eff/Concurrent/Process.hs view

@@ -120,7 +120,6 @@ import           Control.Eff.Exception import           Control.Eff.Extend import           Control.Eff.Log.Handler-import           Control.Eff.Log.Message import           Control.Lens import           Control.Monad                  ( void                                                 , (>=>)@@ -176,7 +175,7 @@   SpawnLink :: Eff (Process r ': r) () -> Process r (ResumeProcess ProcessId)   -- | Get the process state (or 'Nothing' if the process is dead)   GetProcessState :: ProcessId -> Process r (ResumeProcess (Maybe ProcessState))-  -- | Shutdown the process; irregardles of the exit reason, this function never+  -- | Shutdown the process; irregardless of the exit reason, this function never   -- returns,   Shutdown :: ExitReason 'NoRecovery   -> Process r a   -- | Raise an error, that can be handled.@@ -186,13 +185,13 @@   -- interrupt and continue as if nothing happened.   SendInterrupt :: ProcessId -> InterruptReason -> Process r (ResumeProcess ())   -- | Send a message to a process addressed by the 'ProcessId'. Sending a-  -- message should **always succeed** and return **immediately**, even if the+  -- message should __always succeed__ and return __immediately__, even if the   -- destination process does not exist, or does not accept messages of the   -- given type.   SendMessage :: ProcessId -> Dynamic -> Process r (ResumeProcess ())-  -- | Receive a message that matches a criterium.+  -- | Receive a message that matches a criteria.   -- This should block until an a message was received. The message is returned-  -- as a 'ProcessMessage' value. The function should also return if an exception+  -- as a 'ResumeProcess' value. The function should also return if an exception   -- was caught or a shutdown was requested.   ReceiveSelectedMessage :: forall r a . MessageSelector a -> Process r (ResumeProcess a)   -- | Generate a unique 'Int' for the current process.@@ -203,7 +202,7 @@   -- There can be multiple monitors on the same process,   -- and a message for each will be sent.   -- If the process is already dead, the 'ProcessDown' message-  -- will be sent immediately, w.thout exit reason+  -- will be sent immediately, without exit reason   --   -- @since 0.12.0   Monitor :: ProcessId -> Process r (ResumeProcess MonitorReference)@@ -213,11 +212,11 @@   Demonitor :: MonitorReference -> Process r (ResumeProcess ())   -- | Connect the calling process to another process, such that   -- if one of the processes crashes (i.e. 'isCrash' returns 'True'), the other-  -- is shutdown with the 'ProcessExitReaon' 'LinkedProcessCrashed'.+  -- is shutdown with the 'ExitReason' 'LinkedProcessCrashed'.   --   -- @since 0.12.0   Link :: ProcessId -> Process r (ResumeProcess ())-  -- | Unlink the calling proccess from the other process.+  -- | Unlink the calling process from the other process.   --   -- @since 0.12.0   Unlink :: ProcessId -> Process r (ResumeProcess ())@@ -276,7 +275,7 @@  instance NFData1 ResumeProcess --- | A function that deciced if the next message will be received by+-- | A function that decided if the next message will be received by -- 'ReceiveSelectedMessage'. It conveniently is an instance of -- 'Alternative' so the message selector can be combined: -- >@@ -395,7 +394,7 @@ -- @__r__@ in @'Process' r : r@, this might be dependent on the -- scheduler implementation. data SchedulerProxy :: [Type -> Type] -> Type where-  -- | Tell the typechecker what effects we have below 'Process'+  -- | Tell the type checker what effects we have below 'Process'   SchedulerProxy :: SchedulerProxy q   -- | Like 'SchedulerProxy' but shorter   SP :: SchedulerProxy q@@ -412,8 +411,8 @@ -- | The state that a 'Process' is currently in. data ProcessState =     ProcessBooting              -- ^ The process has just been started but not-                                --   called 'handleProcess' yet.-  | ProcessIdle                 -- ^ The process yielded it's timeslice+                                --   scheduled yet.+  | ProcessIdle                 -- ^ The process yielded it's time slice   | ProcessBusy                 -- ^ The process is busy with non-blocking   | ProcessBusySending          -- ^ The process is busy with sending a message   | ProcessBusySendingShutdown  -- ^ The process is busy with killing@@ -447,7 +446,7 @@           NoRecovery  -> showString "not recoverable"         ) --- | Get the 'ExitRecover'y+-- | Get the 'ExitRecovery' toExitRecovery :: ExitReason r -> ExitRecovery toExitRecovery = \case   ProcessFinished           -> Recoverable@@ -459,7 +458,7 @@   (UnexpectedException _ _) -> NoRecovery   Killed                    -> NoRecovery --- | This value indicates wether a process exited in way consistent with+-- | This value indicates whether a process exited in way consistent with -- the planned behaviour or not. data ExitSeverity = NormalExit | Crash   deriving (Typeable, Ord, Eq, Generic)@@ -483,12 +482,12 @@   _                            -> Crash  -- | A sum-type with reasons for why a process exists the scheduling loop,--- this includes errors, that can occur when scheduleing messages.+-- this includes errors, that can occur when scheduling messages. data ExitReason (t :: ExitRecovery) where     -- | A process has finished a unit of work and might exit or work on-    --   something else. This is primarily used for interupting infinite+    --   something else. This is primarily used for interrupting infinite     --   server loops, allowing for additional cleanup work before-    --   exitting (e.g. with 'ExitNormally')+    --   exiting (e.g. with 'ExitNormally')     --     -- @since 0.13.2     ProcessFinished@@ -603,7 +602,7 @@ -- See 'handleInterrupts', 'exitOnInterrupt' or 'provideInterrupts' type Interrupts = Exc InterruptReason --- | This adds a layer of the 'Interrupts' effect ontop of 'ConsProcess'+-- | This adds a layer of the 'Interrupts' effect on top of 'ConsProcess' type InterruptableProcess e = Interrupts ': ConsProcess e  -- | Handle all 'InterruptReason's of an 'InterruptableProcess' by@@ -639,7 +638,7 @@ -- | Handle interrupts by logging them with `logProcessExit` and otherwise -- ignoring them. logInterrupts-  :: (HasCallStack, '[Interrupts, Logs LogMessage] <:: r)+  :: forall r . (Member Logs r, HasCallStack, Member Interrupts r)   => Eff r ()   -> Eff r () logInterrupts = handleInterrupts logProcessExit@@ -667,7 +666,7 @@   :: Either InterruptReason (ExitReason 'NoRecovery) -> ExitReason 'NoRecovery mergeEitherInterruptAndExitReason = either NotRecovered id --- | Throw an 'InterruptReason', can be handled by 'recoverFromInterrupt' or+-- | Throw an 'InterruptReason', can be handled by 'handleInterrupts' or --   'exitOnInterrupt' or 'provideInterrupts'. interrupt :: (HasCallStack, Member Interrupts r) => InterruptReason -> Eff r a interrupt = throwError@@ -680,7 +679,7 @@ isCrash _                 = True  -- | A predicate for recoverable exit reasons. This predicate defines the--- exit reasonson which functions such as 'executeAndResume'+-- exit reasons which functions such as 'executeAndResume' isRecoverable :: ExitReason x -> Bool isRecoverable (toExitRecovery -> Recoverable) = True isRecoverable _                               = False@@ -731,9 +730,8 @@ toCrashReason e | isCrash e = Just (show e)                 | otherwise = Nothing --- | Log the 'ProcessExitReaons'-logProcessExit-  :: (HasCallStack, Member (Logs LogMessage) e) => ExitReason x -> Eff e ()+-- | Log the 'ExitReason's+logProcessExit :: forall e x. (Member Logs e, HasCallStack) => ExitReason x -> Eff e () logProcessExit (toCrashReason -> Just ex) = withFrozenCallStack (logError ex) logProcessExit ex = withFrozenCallStack (logDebug (show ex)) @@ -845,7 +843,7 @@ -- | Start a new process, the new process will execute an effect, the function -- will return immediately with a 'ProcessId'. If the new process is -- interrupted, the process will 'Shutdown' with the 'InterruptReason'--- wrapped in 'NotCovered'. For specific use cases it might be better to use+-- wrapped in 'NotRecovered'. For specific use cases it might be better to use -- 'spawnRaw'. spawn   :: forall r q@@ -955,7 +953,7 @@ -- Only the messages of the given type will be received. -- If the process is interrupted by an exception of by a 'SendShutdown' from -- another process, with an exit reason that satisfies 'isRecoverable', then--- the callback will be invoked with @'Left' 'ProcessExitReaon'@, otherwise the+-- the callback will be invoked with @'Left' 'ExitReason'@, otherwise the -- process will be exited with the same reason using 'exitBecause'. -- See also 'ReceiveSelectedMessage' for more documentation. receiveSelectedLoop@@ -964,12 +962,12 @@   => MessageSelector a   -> (Either InterruptReason a -> Eff r (Maybe endOfLoopResult))   -> Eff r endOfLoopResult-receiveSelectedLoop selectMesage handlers = do-  mReq <- send (ReceiveSelectedMessage @q @a selectMesage)+receiveSelectedLoop selector handlers = do+  mReq <- send (ReceiveSelectedMessage @q @a selector)   mRes <- case mReq of     Interrupted reason  -> handlers (Left reason)     ResumeWith  message -> handlers (Right message)-  maybe (receiveSelectedLoop selectMesage handlers) return mRes+  maybe (receiveSelectedLoop selector handlers) return mRes  -- | Like 'receiveSelectedLoop' but /not selective/. -- See also 'selectAnyMessageLazy', 'receiveSelectedLoop'.@@ -1024,7 +1022,7 @@ -- There can be multiple monitors on the same process, -- and a message for each will be sent. -- If the process is already dead, the 'ProcessDown' message--- will be sent immediately, w.thout exit reason+-- will be sent immediately, without exit reason -- -- @since 0.12.0 monitor@@ -1057,7 +1055,7 @@   => ProcessId   -> (MonitorReference -> Eff r a)   -> Eff r a-withMonitor pid eff = monitor pid >>= \ref -> eff ref <* demonitor ref+withMonitor pid e = monitor pid >>= \ref -> e ref <* demonitor ref  -- | A 'MessageSelector' for receiving either a monitor of the -- given process or another message.@@ -1082,7 +1080,7 @@  -- | A monitored process exited. -- This message is sent to a process by the scheduler, when--- a process that was monitored via a 'SchedulerCommand' died.+-- a process that was monitored died. -- -- @since 0.12.0 data ProcessDown =@@ -1092,9 +1090,10 @@     }   deriving (Typeable, Generic, Eq, Ord) --- | Trigger an 'Interrupt' for a 'ProcessDown' message.--- The reason will be 'ProcessNotRunning'+-- | Make an 'InterruptReason' for a 'ProcessDown' message. --+-- For example: @doSomething >>= either (interrupt . becauseProcessIsDown) return@+-- -- @since 0.12.0 becauseProcessIsDown :: ProcessDown -> InterruptReason becauseProcessIsDown = ProcessNotRunning . monitoredProcess . downReference@@ -1112,7 +1111,7 @@               . showsPrec 11 reason         ) --- | A 'MesssageSelector' for the 'ProcessDown' message of a specific+-- | A 'MessageSelector' for the 'ProcessDown' message of a specific -- process. -- -- @since 0.12.0@@ -1122,7 +1121,7 @@  -- | Connect the calling process to another process, such that -- if one of the processes crashes (i.e. 'isCrash' returns 'True'), the other--- is shutdown with the 'ProcessExitReaon' 'LinkedProcessCrashed'.+-- is shutdown with the 'ExitReason' 'LinkedProcessCrashed'. -- -- @since 0.12.0 linkProcess@@ -1132,7 +1131,7 @@   -> Eff r () linkProcess = executeAndResumeOrThrow . Link . force --- | Unlink the calling proccess from the other process.+-- | Unlink the calling process from the other process. -- -- @since 0.12.0 unlinkProcess@@ -1142,7 +1141,7 @@   -> Eff r () unlinkProcess = executeAndResumeOrThrow . Unlink . force --- | Exit the process with a 'ProcessExitReaon'.+-- | Exit the process with a 'ExitReason'. exitBecause   :: forall r q a    . (HasCallStack, SetMember Process (Process q) r)

src/Control/Eff/Concurrent/Process/ForkIOScheduler.hs view

@@ -1,7 +1,7 @@ -- | Implement Erlang style message passing concurrency. ----- This handles the 'MessagePassing' and 'Process' effects, using--- 'STM.TQueue's and 'forkIO'.+-- This module contains 'spawn' which handles the 'Process' effects, using+-- 'STM.TQueue's and 'Control.Concurrent.Async.withAsync'. -- -- This aims to be a pragmatic implementation, so even logging is -- supported.@@ -10,127 +10,112 @@ -- and creates all of the internal state stored in 'STM.TVar's -- to manage processes with message queues. ----- The 'Eff' handler for 'Process' and 'MessagePassing' use--- are implemented and available through 'spawn'.--- module Control.Eff.Concurrent.Process.ForkIOScheduler   ( schedule   , defaultMain-  , defaultMainWithLogChannel+  , defaultMainWithLogWriter   , ProcEff   , InterruptableProcEff   , SchedulerIO   , HasSchedulerIO-  , forkIoScheduler-  )-where+  ) where -import           Control.Exception.Safe        as Safe-import qualified Control.Eff.ExceptionExtra    as ExcExtra ()-import           Control.Concurrent.STM        as STM-import           Control.Concurrent             (yield)-import qualified Control.Concurrent.Async      as Async-import           Control.Concurrent.Async      (Async(..))-import           Control.Eff-import           Control.Eff.Extend-import           Control.Eff.Concurrent.Process-import           Control.Eff.Lift-import           Control.Eff.Log-import           Control.Eff.Reader.Strict     as Reader-import           Control.Lens-import           Control.Monad                  ( when-                                                , void-                                                , (>=>)-                                                )-import           Control.Monad.Trans.Control     (MonadBaseControl(..))-import           Data.Default-import           Data.Dynamic-import           Data.Foldable-import           Data.Kind                      ( )-import           Data.Map                       ( Map )-import qualified Data.Map                       as Map-import           Data.Set                       ( Set )-import qualified Data.Set                       as Set-import           Data.Maybe-import           Data.Sequence                  ( Seq(..) )-import qualified Data.Sequence                 as Seq-import           GHC.Stack-import           Text.Printf-import           System.Timeout+import Control.Concurrent (yield)+import qualified Control.Concurrent.Async as Async+import Control.Concurrent.Async (Async(..))+import Control.Concurrent.STM as STM+import Control.Eff+import Control.Eff.Concurrent.Process+import qualified Control.Eff.ExceptionExtra as ExcExtra ()+import Control.Eff.Extend+import Control.Eff.Log+import Control.Eff.Reader.Strict as Reader+import Control.Exception.Safe as Safe+import Control.Lens+import Control.Monad (void, when)+import Control.Monad.Trans.Control (MonadBaseControl(..), control)+import Data.Default+import Data.Dynamic+import Data.Foldable+import Data.Function (fix)+import Data.Kind ()+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import Data.Sequence (Seq(..))+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import GHC.Stack+import System.Timeout+import Text.Printf  -- * Process Types  -- | A message queue of a process, contains the actual queue and maybe an--- exit reason.-data MessageQ = MessageQ { _incomingMessages :: Seq Dynamic-                         , _shutdownRequests :: Maybe SomeExitReason-                         }+-- exit reason. The message queue is backed by a 'Seq' sequence with 'Dynamic' values.+data MessageQ = MessageQ+  { _incomingMessages :: Seq Dynamic+  , _shutdownRequests :: Maybe SomeExitReason+  } -instance Default MessageQ where def = MessageQ def def+instance Default MessageQ where+  def = MessageQ def def  makeLenses ''MessageQ  -- | Return any '_shutdownRequests' from a 'MessageQ' in a 'TVar' and -- reset the '_shutdownRequests' field to 'Nothing' in the 'TVar'.-tryTakeNextShutdownRequestSTM-  :: TVar MessageQ -> STM (Maybe SomeExitReason)+tryTakeNextShutdownRequestSTM :: TVar MessageQ -> STM (Maybe SomeExitReason) tryTakeNextShutdownRequestSTM mqVar = do   mq <- readTVar mqVar-  when (isJust (mq^.shutdownRequests))-    (writeTVar mqVar (mq & shutdownRequests .~ Nothing))-  return (mq^.shutdownRequests)-+  when (isJust (mq ^. shutdownRequests)) (writeTVar mqVar (mq & shutdownRequests .~ Nothing))+  return (mq ^. shutdownRequests) --- | Information about a process, needed to implement 'MessagePassing' and--- 'Process' handlers. The message queue is backed by a 'STM.TQueue' and contains--- 'MessageQEntry' values.-data ProcessInfo =-                 ProcessInfo { _processId         :: ProcessId-                             , _processState      :: TVar ProcessState-                             , _messageQ          :: TVar MessageQ-                             , _processLinks      :: TVar (Set ProcessId)-                             }+-- | Information about a process, needed to implement+-- 'Process' handlers. The message queue is backed by a 'STM.TVar' that contains+-- a 'MessageQ'.+data ProcessInfo = ProcessInfo+  { _processId :: ProcessId+  , _processState :: TVar ProcessState+  , _messageQ :: TVar MessageQ+  , _processLinks :: TVar (Set ProcessId)+  }  makeLenses ''ProcessInfo  -- * Scheduler Types  -- | Contains all process info'elements, as well as the state needed to--- implement inter process communication. It contains also a 'LogChannel' to--- which the logs of all processes are forwarded to.-data SchedulerState =-               SchedulerState { _nextPid :: TVar ProcessId-                              , _processTable :: TVar (Map ProcessId ProcessInfo)-                              , _processCancellationTable-                                :: TVar (Map ProcessId-                                    (Async (ExitReason 'NoRecovery)))-                              , _processMonitors :: TVar (Set (MonitorReference, ProcessId))-                              , _nextMonitorIndex :: TVar Int-                              -- Set of monitors and monitor owners-                              }+-- implement inter process communication.+data SchedulerState = SchedulerState+  { _nextPid :: TVar ProcessId+  , _processTable :: TVar (Map ProcessId ProcessInfo)+  , _processCancellationTable :: TVar (Map ProcessId (Async (ExitReason 'NoRecovery)))+  , _processMonitors :: TVar (Set (MonitorReference, ProcessId))  -- ^ Set of monitors and monitor owners+  , _nextMonitorIndex :: TVar Int+  }  makeLenses ''SchedulerState --- | Add monitor: If the process is dead, enqueue a ProcessDown message into the+-- | Add monitor: If the process is dead, enqueue a 'ProcessDown' message into the -- owners message queue addMonitoring :: ProcessId -> ProcessId -> SchedulerState -> STM MonitorReference addMonitoring target owner schedulerState = do-  mi <- readTVar (schedulerState ^. nextMonitorIndex)-  modifyTVar' (schedulerState ^. nextMonitorIndex) (+1)-  let mref = MonitorReference mi target+  aNewMonitorIndex <- readTVar (schedulerState ^. nextMonitorIndex)+  modifyTVar' (schedulerState ^. nextMonitorIndex) (+ 1)+  let monitorRef = MonitorReference aNewMonitorIndex target   when (target /= owner) $ do     pt <- readTVar (schedulerState ^. processTable)-    if Map.member target pt then-      modifyTVar' (schedulerState ^. processMonitors) (Set.insert (mref, owner))-    else-      let pdown = (ProcessDown mref (SomeExitReason (ProcessNotRunning target)))-      in enqueueMessageOtherProcess owner (toDyn pdown) schedulerState-  return mref+    if Map.member target pt+      then modifyTVar' (schedulerState ^. processMonitors) (Set.insert (monitorRef, owner))+      else let processDownMessage = ProcessDown monitorRef (SomeExitReason (ProcessNotRunning target))+            in enqueueMessageOtherProcess owner (toDyn processDownMessage) schedulerState+  return monitorRef  removeMonitoring :: MonitorReference -> SchedulerState -> STM ()-removeMonitoring mref schedulerState =-  modifyTVar' (schedulerState ^. processMonitors)-    (Set.filter (\(ref,_) -> ref /= mref))+removeMonitoring monitorRef schedulerState =+  modifyTVar' (schedulerState ^. processMonitors) (Set.filter (\(ref, _) -> ref /= monitorRef))  triggerAndRemoveMonitor :: ProcessId -> SomeExitReason -> SchedulerState -> STM () triggerAndRemoveMonitor downPid reason schedulerState = do@@ -138,76 +123,60 @@   traverse_ go monRefs   where     go (mr, owner) =-        when (monitoredProcess mr == downPid) (do-          let pdown = ProcessDown mr reason-          enqueueMessageOtherProcess owner (toDyn pdown) schedulerState-          removeMonitoring mr schedulerState)+      when+        (monitoredProcess mr == downPid)+        (do let processDownMessage = ProcessDown mr reason+            enqueueMessageOtherProcess owner (toDyn processDownMessage) schedulerState+            removeMonitoring mr schedulerState)  -- * Process Implementation- instance Show ProcessInfo where-  show p =  "process info: " ++ show (p ^. processId)+  show p = "process info: " ++ show (p ^. processId)  -- | Create a new 'ProcessInfo' newProcessInfo :: HasCallStack => ProcessId -> STM ProcessInfo-newProcessInfo a =-  ProcessInfo a-    <$> newTVar ProcessBooting-    <*> newTVar def-    <*> newTVar def+newProcessInfo a = ProcessInfo a <$> newTVar ProcessBooting <*> newTVar def <*> newTVar def  -- * Scheduler Implementation  -- | Create a new 'SchedulerState' newSchedulerState :: HasCallStack => STM SchedulerState-newSchedulerState =-  SchedulerState-    <$> newTVar 1-    <*> newTVar def-    <*> newTVar def-    <*> newTVar def-    <*> newTVar def+newSchedulerState = SchedulerState <$> newTVar 1 <*> newTVar def <*> newTVar def <*> newTVar def <*> newTVar def  -- | Create a new 'SchedulerState' run an IO action, catching all exceptions, -- and when the actions returns, clean up and kill all processes.-withNewSchedulerState-  :: (HasLogging IO SchedulerIO, HasCallStack)-  => Eff SchedulerIO ()-  -> Eff LoggingAndIO ()+withNewSchedulerState :: (HasCallStack) => Eff SchedulerIO () -> Eff LoggingAndIo () withNewSchedulerState mainProcessAction =-   Safe.bracketWithError+  Safe.bracketWithError     (lift (atomically newSchedulerState))     (\exceptions schedulerState -> do-      traverse_-        (logError . ("scheduler setup crashed with: " ++) . Safe.displayException)-        exceptions-      logDebug "scheduler cleanup begin"-      runReader schedulerState tearDownScheduler-      )-    (\schedulerState  -> do-      logDebug "scheduler loop entered"-      x <- runReader schedulerState mainProcessAction-      logDebug "scheduler loop returned"-      return x-    )-- where+       traverse_ (logError . ("scheduler setup crashed with: " ++) . Safe.displayException) exceptions+       logDebug "scheduler cleanup begin"+       runReader schedulerState tearDownScheduler)+    (\schedulerState -> do+       logDebug "scheduler loop entered"+       x <- runReader schedulerState mainProcessAction+       logDebug "scheduler loop returned"+       return x)+  where+    tearDownScheduler :: Eff SchedulerIO ()     tearDownScheduler = do       schedulerState <- getSchedulerState       let cancelTableVar = schedulerState ^. processCancellationTable       -- cancel all processes       allProcesses <- lift (atomically (readTVar cancelTableVar <* writeTVar cancelTableVar def))-      logNotice ("cancelling processes: " ++ show (toListOf (ifolded.asIndex) allProcesses))+      logNotice ("cancelling processes: " ++ show (toListOf (ifolded . asIndex) allProcesses))       void         (liftBaseWith-          (\runS -> timeout 5000000-            (Async.mapConcurrently-              (\a -> do-                Async.cancel a-                runS (logNotice ("process cancelled: "++ show (asyncThreadId a)))-              )-              allProcesses-             >> runS (logNotice "all processes cancelled"))))+           (\runS ->+              timeout+                5000000+                (Async.mapConcurrently+                   (\a -> do+                      Async.cancel a+                      runS (logNotice ("process cancelled: " ++ show (asyncThreadId a))))+                   allProcesses >>+                 runS (logNotice "all processes cancelled"))))  -- | The concrete list of 'Eff'ects of processes compatible with this scheduler. -- This builds upon 'SchedulerIO'.@@ -218,491 +187,405 @@  -- | Type class constraint to indicate that an effect union contains the -- effects required by every process and the scheduler implementation itself.-type HasSchedulerIO r = ( HasCallStack-                        , Lifted IO r-                        , SchedulerIO <:: r-                        )+type HasSchedulerIO r = (HasCallStack, Lifted IO r, SchedulerIO <:: r)  -- | The concrete list of 'Eff'ects for this scheduler implementation.-type SchedulerIO = ( Reader SchedulerState : LoggingAndIO)---- | Basic effects: 'Logs' 'LogMessage' and 'Lift' IO-type LoggingAndIO =-              '[ Logs LogMessage-               , LogWriterReader LogMessage IO-               , Lift IO-               ]+type SchedulerIO = (Reader SchedulerState : LoggingAndIo)  -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output. defaultMain :: HasCallStack => Eff InterruptableProcEff () -> IO ()-defaultMain c =-  withAsyncLogChannel (1024 :: Int)-    (multiMessageLogWriter ($ printLogMessage))-    (handleLoggingAndIO_ (schedule c))+defaultMain = defaultMainWithLogWriter consoleLogWriter  -- | Start the message passing concurrency system then execute a 'Process' on -- top of 'SchedulerIO' effect. All logging is sent to standard output.-defaultMainWithLogChannel-  :: HasCallStack => Eff InterruptableProcEff () -> LogChannel LogMessage -> IO ()-defaultMainWithLogChannel = handleLoggingAndIO_ . schedule---- | A 'SchedulerProxy' for 'SchedulerIO'-forkIoScheduler :: SchedulerProxy SchedulerIO-forkIoScheduler = SchedulerProxy-+defaultMainWithLogWriter :: HasCallStack => LogWriter IO -> Eff InterruptableProcEff () -> IO ()+defaultMainWithLogWriter lw =+  runLift . withSomeLogging . withAsyncLogging (1024 :: Int) lw . schedule --- ** MessagePassing execution+-- ** Process Execution -handleProcess-  :: (HasLogging IO SchedulerIO, HasCallStack)-  => ProcessInfo-  -> Eff ProcEff (ExitReason 'NoRecovery)-  -> Eff SchedulerIO (ExitReason 'NoRecovery)-handleProcess myProcessInfo =-  handle_relay_s-    0-    (const return)-    (\ !nextRef !request k ->-       stepProcessInterpreter nextRef request k return-    )- where-  myPid = myProcessInfo ^. processId-  myProcessStateVar = myProcessInfo ^. processState-  setMyProcessState = lift . atomically . setMyProcessStateSTM+handleProcess ::+     (HasCallStack) => ProcessInfo -> Eff ProcEff (ExitReason 'NoRecovery) -> Eff SchedulerIO (ExitReason 'NoRecovery)+handleProcess myProcessInfo actionToRun =+  fix (handle_relay' singleStep (const . const (return ExitNormally))) actionToRun 0+  where+    singleStep ::+         (Eff ProcEff xx -> (Int -> Eff SchedulerIO (ExitReason 'NoRecovery)))+      -> Arrs ProcEff x xx+      -> Process SchedulerIO x+      -> (Int -> Eff SchedulerIO (ExitReason 'NoRecovery))+    singleStep k q p !nextRef = stepProcessInterpreter nextRef p (\nextNextRef x -> k (qApp q x) nextNextRef) return+    myPid = myProcessInfo ^. processId+    myProcessStateVar = myProcessInfo ^. processState+    setMyProcessState = lift . atomically . setMyProcessStateSTM   -- DEBUG variant:   -- setMyProcessState st = do   --  oldSt <- lift (atomically (readTVar myProcessStateVar <* setMyProcessStateSTM st))   --  logDebug ("state change: "++ show oldSt ++ " -> " ++ show st)--  setMyProcessStateSTM = writeTVar myProcessStateVar-  myMessageQVar = myProcessInfo ^. messageQ--  kontinueWith-    :: forall s v a-    .  HasCallStack-    => (s -> Arr SchedulerIO v a)-    -> s-    -> Arr SchedulerIO v a-  kontinueWith kontinue !nextRef !result = do-    setMyProcessState ProcessIdle-    lift yield-    kontinue nextRef result--  diskontinueWith-    :: forall a-    .  HasCallStack-    => Arr SchedulerIO (ExitReason 'NoRecovery) a-    -> Arr SchedulerIO (ExitReason 'NoRecovery) a-  diskontinueWith diskontinue !reason = do-    setMyProcessState ProcessShuttingDown-    diskontinue reason--  stepProcessInterpreter-    :: forall v a-     . HasCallStack-    => Int-    -> Process SchedulerIO v-    -> (Int -> Arr SchedulerIO v a)-    -> Arr SchedulerIO (ExitReason 'NoRecovery) a-    -> Eff SchedulerIO a-  stepProcessInterpreter !nextRef !request kontinue diskontinue =-+    setMyProcessStateSTM = writeTVar myProcessStateVar+    myMessageQVar = myProcessInfo ^. messageQ+    kontinueWith ::+         forall s v a. HasCallStack+      => (s -> Arr SchedulerIO v a)+      -> (s -> Arr SchedulerIO v a)+    kontinueWith kontinue !nextRef !result = do+      setMyProcessState ProcessIdle+      lift yield+      kontinue nextRef result+    diskontinueWith ::+         forall a. HasCallStack+      => Arr SchedulerIO (ExitReason 'NoRecovery) a+      -> Arr SchedulerIO (ExitReason 'NoRecovery) a+    diskontinueWith diskontinue !reason = do+      setMyProcessState ProcessShuttingDown+      diskontinue reason+    stepProcessInterpreter ::+         forall v a. HasCallStack+      => Int+      -> Process SchedulerIO v+      -> (Int -> Arr SchedulerIO v a)+      -> Arr SchedulerIO (ExitReason 'NoRecovery) a+      -> Eff SchedulerIO a+    stepProcessInterpreter !nextRef !request kontinue diskontinue       -- handle process shutdown requests:       --   1. take process exit reason       --   2. set process state to ProcessShuttingDown       --   3. apply kontinue to (Right Interrupted)       ---      tryTakeNextShutdownRequest-        >>= maybe noShutdownRequested-            (either onShutdownRequested onInterruptRequested-              . fromSomeExitReason)+     =+      tryTakeNextShutdownRequest >>=+      maybe noShutdownRequested (either onShutdownRequested onInterruptRequested . fromSomeExitReason)       where-        tryTakeNextShutdownRequest =-          lift (atomically (tryTakeNextShutdownRequestSTM myMessageQVar))-+        tryTakeNextShutdownRequest = lift (atomically (tryTakeNextShutdownRequestSTM myMessageQVar))         onShutdownRequested shutdownRequest = do-           logDebug ("shutdown requested: " ++ show shutdownRequest)-           setMyProcessState ProcessShuttingDown-           interpretRequestAfterShutdownRequest-             (diskontinueWith diskontinue)-             shutdownRequest-             request-+          logDebug ("shutdown requested: " ++ show shutdownRequest)+          setMyProcessState ProcessShuttingDown+          interpretRequestAfterShutdownRequest (diskontinueWith diskontinue) shutdownRequest request         onInterruptRequested interruptRequest = do-           logDebug ("interrupt requested: " ++ show interruptRequest)-           setMyProcessState ProcessShuttingDown-           interpretRequestAfterInterruptRequest-             (kontinueWith kontinue nextRef)-             (diskontinueWith diskontinue)-             interruptRequest-             request-+          logDebug ("interrupt requested: " ++ show interruptRequest)+          setMyProcessState ProcessShuttingDown+          interpretRequestAfterInterruptRequest+            (kontinueWith kontinue nextRef)+            (diskontinueWith diskontinue)+            interruptRequest+            request         noShutdownRequested = do-           setMyProcessState ProcessBusy-           interpretRequest-             (kontinueWith kontinue)-             (diskontinueWith diskontinue)-             nextRef-             request-+          setMyProcessState ProcessBusy+          interpretRequest (kontinueWith kontinue) (diskontinueWith diskontinue) nextRef request   -- This gets no nextRef and may not pass a Left value to the continuation.   -- This forces the caller to defer the process exit to the next request   -- and hence ensures that the scheduler code cannot forget to allow the   -- client code to react to a shutdown request.-  interpretRequestAfterShutdownRequest-    :: forall v a-     . HasCallStack-    => Arr SchedulerIO (ExitReason 'NoRecovery) a-    -> (ExitReason 'NoRecovery)-    -> Process SchedulerIO v-    -> Eff SchedulerIO a-  interpretRequestAfterShutdownRequest diskontinue shutdownRequest =-    \case-      SendMessage _ _          -> diskontinue shutdownRequest-      SendInterrupt _ _        -> diskontinue shutdownRequest-      SendShutdown toPid r     ->-        if toPid == myPid-          then diskontinue r-          else diskontinue shutdownRequest-      Spawn _                  -> diskontinue shutdownRequest-      SpawnLink _              -> diskontinue shutdownRequest-      ReceiveSelectedMessage _ -> diskontinue shutdownRequest-      FlushMessages            -> diskontinue shutdownRequest-      SelfPid                  -> diskontinue shutdownRequest-      MakeReference            -> diskontinue shutdownRequest-      YieldProcess             -> diskontinue shutdownRequest-      Shutdown r               -> diskontinue r-      GetProcessState _        -> diskontinue shutdownRequest-      Monitor _                -> diskontinue shutdownRequest-      Demonitor _              -> diskontinue shutdownRequest-      Link _                   -> diskontinue shutdownRequest-      Unlink _                 -> diskontinue shutdownRequest--  interpretRequestAfterInterruptRequest-    :: forall v a-     . HasCallStack-    => Arr SchedulerIO v a-    -> Arr SchedulerIO (ExitReason 'NoRecovery) a-    -> (ExitReason 'Recoverable)-    -> Process SchedulerIO v-    -> Eff SchedulerIO a-  interpretRequestAfterInterruptRequest kontinue diskontinue interruptRequest =-    \case-      SendMessage _ _          -> kontinue (Interrupted interruptRequest)-      SendInterrupt _ _        -> kontinue (Interrupted interruptRequest)-      SendShutdown toPid r     ->-        if toPid == myPid-          then diskontinue r-          else kontinue (Interrupted interruptRequest)-      Spawn _                  -> kontinue (Interrupted interruptRequest)-      SpawnLink _              -> kontinue (Interrupted interruptRequest)-      ReceiveSelectedMessage _ -> kontinue (Interrupted interruptRequest)-      FlushMessages            -> kontinue (Interrupted interruptRequest)-      SelfPid                  -> kontinue (Interrupted interruptRequest)-      MakeReference            -> kontinue (Interrupted interruptRequest)-      YieldProcess             -> kontinue (Interrupted interruptRequest)-      Shutdown r               -> diskontinue r-      GetProcessState _        -> kontinue (Interrupted interruptRequest)-      Monitor _                -> kontinue (Interrupted interruptRequest)-      Demonitor _              -> kontinue (Interrupted interruptRequest)-      Link _                   -> kontinue (Interrupted interruptRequest)-      Unlink _                 -> kontinue (Interrupted interruptRequest)--  interpretRequest-    :: forall v a-     . HasCallStack-    => (Int -> Arr SchedulerIO v a)-    -> Arr SchedulerIO (ExitReason 'NoRecovery) a-    -> Int-    -> Process SchedulerIO v-    -> Eff SchedulerIO a-  interpretRequest kontinue diskontinue nextRef =-    \case-      SendMessage toPid msg     -> interpretSend toPid msg >>= kontinue nextRef . ResumeWith-      SendInterrupt toPid msg   ->-        if toPid == myPid-          then kontinue nextRef (Interrupted msg)-          else interpretSendShutdownOrInterrupt toPid (SomeExitReason msg)-                 >>= kontinue nextRef . ResumeWith-      SendShutdown toPid msg   ->-        if toPid == myPid-          then diskontinue msg-          else interpretSendShutdownOrInterrupt toPid (SomeExitReason msg)-                 >>= kontinue nextRef . ResumeWith-      Spawn child              -> spawnNewProcess Nothing child-                                    >>= kontinue nextRef . ResumeWith . fst-      SpawnLink child          -> spawnNewProcess (Just myProcessInfo) child-                                    >>= kontinue nextRef . ResumeWith . fst-      ReceiveSelectedMessage f -> interpretReceive f >>= either diskontinue (kontinue nextRef)-      FlushMessages            -> interpretFlush >>= kontinue nextRef-      SelfPid                  -> kontinue nextRef (ResumeWith myPid)-      MakeReference            -> kontinue (nextRef + 1) (ResumeWith nextRef)-      YieldProcess             -> kontinue nextRef (ResumeWith  ())-      Shutdown r               -> diskontinue r-      GetProcessState toPid    -> interpretGetProcessState toPid >>= kontinue nextRef . ResumeWith-      Monitor target           -> interpretMonitor target >>= kontinue nextRef . ResumeWith-      Demonitor ref            -> interpretDemonitor ref >>= kontinue nextRef . ResumeWith-      Link toPid               -> interpretLink toPid-                                    >>= kontinue nextRef . either Interrupted ResumeWith-      Unlink toPid             -> interpretUnlink toPid >>= kontinue nextRef . ResumeWith-    where-      interpretMonitor !target = do-        setMyProcessState ProcessBusyMonitoring-        schedulerState <- getSchedulerState-        lift (atomically (addMonitoring target myPid schedulerState))--      interpretDemonitor !ref = do-        setMyProcessState ProcessBusyMonitoring-        schedulerState <- getSchedulerState-        lift (atomically (removeMonitoring ref schedulerState))--      interpretUnlink !toPid = do-        setMyProcessState ProcessBusyUnlinking-        schedulerState <- getSchedulerState-        let procInfosVar = schedulerState^.processTable-        lift $ atomically $ do-          procInfos <- readTVar procInfosVar-          traverse_-            (\toProcInfo ->-              modifyTVar' (toProcInfo ^. processLinks) (Set.delete myPid))-            (procInfos ^. at toPid)-          modifyTVar' (myProcessInfo ^. processLinks) (Set.delete toPid)--      interpretGetProcessState !toPid = do-        setMyProcessState ProcessBusy-        schedulerState <- getSchedulerState-        let procInfosVar = schedulerState^.processTable-        lift $ atomically $ do-          procInfos <- readTVar procInfosVar-          traverse (\toProcInfo -> readTVar (toProcInfo ^. processState))-                   (procInfos ^. at toPid)--      interpretLink !toPid = do-        setMyProcessState ProcessBusyLinking-        schedulerState <- getSchedulerState-        let procInfosVar = schedulerState^.processTable-        lift $ atomically $ do-          procInfos <- readTVar procInfosVar-          case procInfos ^. at toPid of-            Just toProcInfo -> do-              modifyTVar' (toProcInfo ^. processLinks) (Set.insert myPid)-              modifyTVar' (myProcessInfo ^. processLinks) (Set.insert toPid)-              return (Right ())-            Nothing ->-              return (Left (LinkedProcessCrashed toPid))--      interpretSend !toPid msg =-        setMyProcessState ProcessBusySending *>-        getSchedulerState-          >>= lift-          . atomically-          . enqueueMessageOtherProcess toPid msg--      interpretSendShutdownOrInterrupt !toPid !msg =-        setMyProcessState-          (either-            (const ProcessBusySendingShutdown)-            (const ProcessBusySendingInterrupt)-            (fromSomeExitReason msg))-        *> getSchedulerState-           >>= lift-           . atomically-           . enqueueShutdownRequest toPid msg--      interpretFlush :: Eff SchedulerIO (ResumeProcess [Dynamic])-      interpretFlush = do-        setMyProcessState ProcessBusyReceiving-        lift $ atomically $ do-          myMessageQ <- readTVar myMessageQVar-          modifyTVar' myMessageQVar (incomingMessages .~ Seq.Empty)-          return (ResumeWith (toList (myMessageQ ^. incomingMessages)))--      interpretReceive-        :: MessageSelector b-        -> Eff SchedulerIO (Either (ExitReason 'NoRecovery) (ResumeProcess b))-      interpretReceive f = do-        setMyProcessState ProcessBusyReceiving-        lift $ atomically $ do-          myMessageQ <- readTVar myMessageQVar-          case myMessageQ ^. shutdownRequests of-            Nothing ->-              case partitionMessages (myMessageQ ^. incomingMessages) Seq.Empty of-                Nothing -> retry-                Just (selectedMessage, otherMessages) -> do-                  modifyTVar' myMessageQVar (incomingMessages .~ otherMessages)-                  return (Right (ResumeWith selectedMessage))-            Just shutdownRequest -> do-              modifyTVar' myMessageQVar (shutdownRequests .~ Nothing)-              case fromSomeExitReason shutdownRequest of-                Left sr ->-                  return (Left sr)-                Right ir ->-                  return (Right (Interrupted ir))--       where-         partitionMessages Seq.Empty       _acc = Nothing-         partitionMessages (m :<| msgRest) acc  = maybe-           (partitionMessages msgRest (acc :|> m))-           (\res -> Just (res, acc Seq.>< msgRest))-           (runMessageSelector f m)+    interpretRequestAfterShutdownRequest ::+         forall v a. HasCallStack+      => Arr SchedulerIO (ExitReason 'NoRecovery) a+      -> ExitReason 'NoRecovery+      -> Process SchedulerIO v+      -> Eff SchedulerIO a+    interpretRequestAfterShutdownRequest diskontinue shutdownRequest =+      \case+        SendMessage _ _ -> diskontinue shutdownRequest+        SendInterrupt _ _ -> diskontinue shutdownRequest+        SendShutdown toPid r ->+          if toPid == myPid+            then diskontinue r+            else diskontinue shutdownRequest+        Spawn _ -> diskontinue shutdownRequest+        SpawnLink _ -> diskontinue shutdownRequest+        ReceiveSelectedMessage _ -> diskontinue shutdownRequest+        FlushMessages -> diskontinue shutdownRequest+        SelfPid -> diskontinue shutdownRequest+        MakeReference -> diskontinue shutdownRequest+        YieldProcess -> diskontinue shutdownRequest+        Shutdown r -> diskontinue r+        GetProcessState _ -> diskontinue shutdownRequest+        Monitor _ -> diskontinue shutdownRequest+        Demonitor _ -> diskontinue shutdownRequest+        Link _ -> diskontinue shutdownRequest+        Unlink _ -> diskontinue shutdownRequest+    interpretRequestAfterInterruptRequest ::+         forall v a. HasCallStack+      => Arr SchedulerIO v a+      -> Arr SchedulerIO (ExitReason 'NoRecovery) a+      -> ExitReason 'Recoverable+      -> Process SchedulerIO v+      -> Eff SchedulerIO a+    interpretRequestAfterInterruptRequest kontinue diskontinue interruptRequest =+      \case+        SendMessage _ _ -> kontinue (Interrupted interruptRequest)+        SendInterrupt _ _ -> kontinue (Interrupted interruptRequest)+        SendShutdown toPid r ->+          if toPid == myPid+            then diskontinue r+            else kontinue (Interrupted interruptRequest)+        Spawn _ -> kontinue (Interrupted interruptRequest)+        SpawnLink _ -> kontinue (Interrupted interruptRequest)+        ReceiveSelectedMessage _ -> kontinue (Interrupted interruptRequest)+        FlushMessages -> kontinue (Interrupted interruptRequest)+        SelfPid -> kontinue (Interrupted interruptRequest)+        MakeReference -> kontinue (Interrupted interruptRequest)+        YieldProcess -> kontinue (Interrupted interruptRequest)+        Shutdown r -> diskontinue r+        GetProcessState _ -> kontinue (Interrupted interruptRequest)+        Monitor _ -> kontinue (Interrupted interruptRequest)+        Demonitor _ -> kontinue (Interrupted interruptRequest)+        Link _ -> kontinue (Interrupted interruptRequest)+        Unlink _ -> kontinue (Interrupted interruptRequest)+    interpretRequest ::+         forall v a. HasCallStack+      => (Int -> Arr SchedulerIO v a)+      -> Arr SchedulerIO (ExitReason 'NoRecovery) a+      -> Int+      -> Process SchedulerIO v+      -> Eff SchedulerIO a+    interpretRequest kontinue diskontinue nextRef =+      \case+        SendMessage toPid msg -> interpretSend toPid msg >>= kontinue nextRef . ResumeWith+        SendInterrupt toPid msg ->+          if toPid == myPid+            then kontinue nextRef (Interrupted msg)+            else interpretSendShutdownOrInterrupt toPid (SomeExitReason msg) >>= kontinue nextRef . ResumeWith+        SendShutdown toPid msg ->+          if toPid == myPid+            then diskontinue msg+            else interpretSendShutdownOrInterrupt toPid (SomeExitReason msg) >>= kontinue nextRef . ResumeWith+        Spawn child -> spawnNewProcess Nothing child >>= kontinue nextRef . ResumeWith . fst+        SpawnLink child -> spawnNewProcess (Just myProcessInfo) child >>= kontinue nextRef . ResumeWith . fst+        ReceiveSelectedMessage f -> interpretReceive f >>= either diskontinue (kontinue nextRef)+        FlushMessages -> interpretFlush >>= kontinue nextRef+        SelfPid -> kontinue nextRef (ResumeWith myPid)+        MakeReference -> kontinue (nextRef + 1) (ResumeWith nextRef)+        YieldProcess -> kontinue nextRef (ResumeWith ())+        Shutdown r -> diskontinue r+        GetProcessState toPid -> interpretGetProcessState toPid >>= kontinue nextRef . ResumeWith+        Monitor target -> interpretMonitor target >>= kontinue nextRef . ResumeWith+        Demonitor ref -> interpretDemonitor ref >>= kontinue nextRef . ResumeWith+        Link toPid -> interpretLink toPid >>= kontinue nextRef . either Interrupted ResumeWith+        Unlink toPid -> interpretUnlink toPid >>= kontinue nextRef . ResumeWith+      where+        interpretMonitor !target = do+          setMyProcessState ProcessBusyMonitoring+          schedulerState <- getSchedulerState+          lift (atomically (addMonitoring target myPid schedulerState))+        interpretDemonitor !ref = do+          setMyProcessState ProcessBusyMonitoring+          schedulerState <- getSchedulerState+          lift (atomically (removeMonitoring ref schedulerState))+        interpretUnlink !toPid = do+          setMyProcessState ProcessBusyUnlinking+          schedulerState <- getSchedulerState+          let procInfoVar = schedulerState ^. processTable+          lift $+            atomically $ do+              procInfo <- readTVar procInfoVar+              traverse_+                (\toProcInfo -> modifyTVar' (toProcInfo ^. processLinks) (Set.delete myPid))+                (procInfo ^. at toPid)+              modifyTVar' (myProcessInfo ^. processLinks) (Set.delete toPid)+        interpretGetProcessState !toPid = do+          setMyProcessState ProcessBusy+          schedulerState <- getSchedulerState+          let procInfoVar = schedulerState ^. processTable+          lift $+            atomically $ do+              procInfoTable <- readTVar procInfoVar+              traverse (\toProcInfo -> readTVar (toProcInfo ^. processState)) (procInfoTable ^. at toPid)+        interpretLink !toPid = do+          setMyProcessState ProcessBusyLinking+          schedulerState <- getSchedulerState+          let procInfoVar = schedulerState ^. processTable+          lift $+            atomically $ do+              procInfoTable <- readTVar procInfoVar+              case procInfoTable ^. at toPid of+                Just toProcInfo -> do+                  modifyTVar' (toProcInfo ^. processLinks) (Set.insert myPid)+                  modifyTVar' (myProcessInfo ^. processLinks) (Set.insert toPid)+                  return (Right ())+                Nothing -> return (Left (LinkedProcessCrashed toPid))+        interpretSend !toPid msg =+          setMyProcessState ProcessBusySending *> getSchedulerState >>=+          lift . atomically . enqueueMessageOtherProcess toPid msg+        interpretSendShutdownOrInterrupt !toPid !msg =+          setMyProcessState+            (either (const ProcessBusySendingShutdown) (const ProcessBusySendingInterrupt) (fromSomeExitReason msg)) *>+          getSchedulerState >>=+          lift . atomically . enqueueShutdownRequest toPid msg+        interpretFlush :: Eff SchedulerIO (ResumeProcess [Dynamic])+        interpretFlush = do+          setMyProcessState ProcessBusyReceiving+          lift $+            atomically $ do+              myMessageQ <- readTVar myMessageQVar+              modifyTVar' myMessageQVar (incomingMessages .~ Seq.Empty)+              return (ResumeWith (toList (myMessageQ ^. incomingMessages)))+        interpretReceive :: MessageSelector b -> Eff SchedulerIO (Either (ExitReason 'NoRecovery) (ResumeProcess b))+        interpretReceive f = do+          setMyProcessState ProcessBusyReceiving+          lift $+            atomically $ do+              myMessageQ <- readTVar myMessageQVar+              case myMessageQ ^. shutdownRequests of+                Nothing ->+                  case partitionMessages (myMessageQ ^. incomingMessages) Seq.Empty of+                    Nothing -> retry+                    Just (selectedMessage, otherMessages) -> do+                      modifyTVar' myMessageQVar (incomingMessages .~ otherMessages)+                      return (Right (ResumeWith selectedMessage))+                Just shutdownRequest -> do+                  modifyTVar' myMessageQVar (shutdownRequests .~ Nothing)+                  case fromSomeExitReason shutdownRequest of+                    Left sr -> return (Left sr)+                    Right ir -> return (Right (Interrupted ir))+          where+            partitionMessages Seq.Empty _acc = Nothing+            partitionMessages (m :<| msgRest) acc =+              maybe+                (partitionMessages msgRest (acc :|> m))+                (\res -> Just (res, acc Seq.>< msgRest))+                (runMessageSelector f m)  -- | 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-  :: (HasLogging IO SchedulerIO, HasCallStack)-  => Eff InterruptableProcEff ()-  -> Eff LoggingAndIO ()+-- effect for concurrent logging.+schedule :: (HasCallStack) => Eff InterruptableProcEff () -> Eff LoggingAndIo () schedule procEff =-  liftBaseWith (\runS ->-    Async.withAsync (runS $ withNewSchedulerState $ do-        (_, mainProcAsync) <- spawnNewProcess Nothing $ do-          logNotice "++++++++ main process started ++++++++"-          provideInterruptsShutdown procEff-          logNotice "++++++++ main process returned ++++++++"-        lift (void (Async.wait mainProcAsync))-      )-      (\ast -> runS $ do-        a <- restoreM ast-        void $ lift (Async.wait a)-      )-  ) >>= restoreM+  liftBaseWith+    (\runS ->+       Async.withAsync+         (runS $+          withNewSchedulerState $ do+            (_, mainProcAsync) <-+              spawnNewProcess Nothing $ do+                logNotice "++++++++ main process started ++++++++"+                provideInterruptsShutdown procEff+                logNotice "++++++++ main process returned ++++++++"+            lift (void (Async.wait mainProcAsync)))+         (\ast ->+            runS $ do+              a <- restoreM ast+              void $ lift (Async.wait a))) >>=+  restoreM -spawnNewProcess-  :: (HasLogging IO SchedulerIO, HasCallStack)+spawnNewProcess ::+     (HasCallStack)   => Maybe ProcessInfo   -> Eff ProcEff ()   -> Eff SchedulerIO (ProcessId, Async (ExitReason 'NoRecovery))-spawnNewProcess mlinkedParent mfa = do+spawnNewProcess mLinkedParent mfa = do   schedulerState <- getSchedulerState   procInfo <- allocateProcInfo schedulerState-  traverse_ (linkToParent procInfo) mlinkedParent+  traverse_ (linkToParent procInfo) mLinkedParent   procAsync <- doForkProc procInfo schedulerState   return (procInfo ^. processId, procAsync)- where+  where     linkToParent toProcInfo parent = do       let toPid = toProcInfo ^. processId           parentPid = parent ^. processId-      lift $ atomically $ do-        modifyTVar' (toProcInfo ^. processLinks) (Set.insert parentPid)-        modifyTVar' (parent ^. processLinks) (Set.insert toPid)-+      lift $+        atomically $ do+          modifyTVar' (toProcInfo ^. processLinks) (Set.insert parentPid)+          modifyTVar' (parent ^. processLinks) (Set.insert toPid)     allocateProcInfo schedulerState =-      lift (atomically (do-          let nextPidVar = schedulerState ^. nextPid-              processInfosVar = schedulerState ^. processTable-          pid <- readTVar nextPidVar-          modifyTVar' nextPidVar (+1)-          procInfo <- newProcessInfo pid-          modifyTVar' processInfosVar (at pid ?~ procInfo)-          return procInfo-          ))-+      lift+        (atomically+           (do let nextPidVar = schedulerState ^. nextPid+                   processInfoVar = schedulerState ^. processTable+               pid <- readTVar nextPidVar+               modifyTVar' nextPidVar (+ 1)+               procInfo <- newProcessInfo pid+               modifyTVar' processInfoVar (at pid ?~ procInfo)+               return procInfo))     logAppendProcInfo pid =-      let addProcessId = over lmProcessId-            (maybe (Just (printf "% 9s" (show pid))) Just)-      in traverseLogMessages-         (traverse setLogMessageThreadId-          >=> traverse (return . addProcessId))-+      let addProcessId = over lmProcessId (maybe (Just (printf "% 9s" (show pid))) Just)+       in censorLogs @IO addProcessId+    triggerProcessLinksAndMonitors :: ProcessId -> ExitReason e -> TVar (Set ProcessId) -> Eff SchedulerIO ()     triggerProcessLinksAndMonitors !pid !reason !linkSetVar = do       schedulerState <- getSchedulerState-      lift $ atomically $-        triggerAndRemoveMonitor pid (SomeExitReason reason) schedulerState+      lift $ atomically $ triggerAndRemoveMonitor pid (SomeExitReason reason) schedulerState       let exitSeverity = toExitSeverity reason           sendIt !linkedPid = do             let msg = SomeExitReason (LinkedProcessCrashed pid)-            lift $ atomically $ do-              procInfos <- readTVar (schedulerState ^. processTable)-              let mLinkedProcInfo = procInfos ^? at linkedPid . _Just-              case mLinkedProcInfo of-                Nothing ->-                  return (Left linkedPid)-                Just linkedProcInfo ->-                  let linkedMsgQVar    = linkedProcInfo ^. messageQ-                      linkedLinkSetVar = linkedProcInfo ^. processLinks-                  in do linkedLinkSet <- readTVar linkedLinkSetVar-                        if Set.member pid linkedLinkSet-                          then do-                            writeTVar   linkedLinkSetVar-                                        (Set.delete pid linkedLinkSet)-                            when (exitSeverity == Crash)-                              (modifyTVar' linkedMsgQVar-                                          (shutdownRequests ?~ msg))-                            return (Right linkedPid)-                          else-                            return (Left linkedPid)-      linkedPids <- lift (atomically (do linkSet <- readTVar linkSetVar-                                         writeTVar linkSetVar def-                                         return linkSet))+            lift $+              atomically $ do+                procInfoTable <- readTVar (schedulerState ^. processTable)+                let mLinkedProcInfo = procInfoTable ^? ix linkedPid+                case mLinkedProcInfo of+                  Nothing -> return (Left linkedPid)+                  Just linkedProcInfo ->+                    let linkedMsgQVar = linkedProcInfo ^. messageQ+                        linkedLinkSetVar = linkedProcInfo ^. processLinks+                     in do linkedLinkSet <- readTVar linkedLinkSetVar+                           if Set.member pid linkedLinkSet+                             then do+                               writeTVar linkedLinkSetVar (Set.delete pid linkedLinkSet)+                               when (exitSeverity == Crash) (modifyTVar' linkedMsgQVar (shutdownRequests ?~ msg))+                               return (Right linkedPid)+                             else return (Left linkedPid)+      linkedPids <-+        lift+          (atomically+             (do linkSet <- readTVar linkSetVar+                 writeTVar linkSetVar def+                 return linkSet))       res <- traverse sendIt (toList linkedPids)-      traverse_ (logDebug . either (("linked process no found: " ++) . show)-                (("sent shutdown to linked process: " ++) . show))-                res-+      traverse_+        (logDebug . either (("linked process no found: " ++) . show) (("sent shutdown to linked process: " ++) . show))+        res     doForkProc :: ProcessInfo -> SchedulerState -> Eff SchedulerIO (Async (ExitReason 'NoRecovery))     doForkProc procInfo schedulerState =-      restoreM =<< liftBaseWith+      control         (\inScheduler -> do-          let cancellationsVar = schedulerState ^. processCancellationTable-              processInfosVar = schedulerState ^. processTable-              pid = procInfo ^. processId-          procAsync <- Async.async (-            inScheduler (logAppendProcInfo pid-            (Safe.bracketWithError-                  (logDebug "enter process")-                  (\mExc () -> do-                         lift (atomically-                           (do modifyTVar' processInfosVar (at pid .~ Nothing)-                               modifyTVar' cancellationsVar (at pid .~ Nothing)))-                         traverse_-                           (\exc -> logExitAndTriggerLinksAndMonitors-                                      (exitReasonFromException exc)-                                      pid)-                           mExc-                  )-                  (const-                    (do res <- handleProcess procInfo (mfa >> return ExitNormally)-                        logExitAndTriggerLinksAndMonitors res pid))-                )))-          atomically (modifyTVar' cancellationsVar (at pid ?~ procAsync))-          return procAsync)+           let cancellationsVar = schedulerState ^. processCancellationTable+               processInfoVar = schedulerState ^. processTable+               pid = procInfo ^. processId+           procAsync <-+             Async.async+               (inScheduler+                  (logAppendProcInfo+                     pid+                     (Safe.bracketWithError+                        (logDebug "enter process")+                        (\mExc () -> do+                           lift+                             (atomically+                                (do modifyTVar' processInfoVar (at pid .~ Nothing)+                                    modifyTVar' cancellationsVar (at pid .~ Nothing)))+                           traverse_ (\exc -> logExitAndTriggerLinksAndMonitors (exitReasonFromException exc) pid) mExc)+                        (const+                           (do res <- handleProcess procInfo (mfa >> return ExitNormally)+                               logExitAndTriggerLinksAndMonitors res pid)))))+           atomically (modifyTVar' cancellationsVar (at pid ?~ procAsync))+           return procAsync)       where         exitReasonFromException exc =-            case Safe.fromException exc of-              Just Async.AsyncCancelled ->-                Killed--              Nothing ->-                UnexpectedException-                    (prettyCallStack callStack)-                    (Safe.displayException exc)--        logExitAndTriggerLinksAndMonitors reason pid =-          do triggerProcessLinksAndMonitors pid reason (procInfo ^. processLinks)-             logProcessExit reason-             return reason+          case Safe.fromException exc of+            Just Async.AsyncCancelled -> Killed+            Nothing -> UnexpectedException (prettyCallStack callStack) (Safe.displayException exc)+        logExitAndTriggerLinksAndMonitors reason pid = do+          triggerProcessLinksAndMonitors pid reason (procInfo ^. processLinks)+          logProcessExit reason+          return reason  -- * Scheduler Accessor- getSchedulerState :: HasSchedulerIO r => Eff r SchedulerState getSchedulerState = ask -enqueueMessageOtherProcess ::-  HasCallStack => ProcessId -> Dynamic -> SchedulerState -> STM ()+enqueueMessageOtherProcess :: HasCallStack => ProcessId -> Dynamic -> SchedulerState -> STM () enqueueMessageOtherProcess toPid msg schedulerState =-  view (at toPid) <$> readTVar (schedulerState ^. processTable)-   >>= maybe (return ())-             (\toProcessTable -> do-                modifyTVar' (toProcessTable ^. messageQ ) (incomingMessages %~ (:|> msg))-                return ())+  view (at toPid) <$> readTVar (schedulerState ^. processTable) >>=+  maybe+    (return ())+    (\toProcessTable -> do+       modifyTVar' (toProcessTable ^. messageQ) (incomingMessages %~ (:|> msg))+       return ()) -enqueueShutdownRequest ::-  HasCallStack => ProcessId -> SomeExitReason -> SchedulerState -> STM ()+enqueueShutdownRequest :: HasCallStack => ProcessId -> SomeExitReason -> SchedulerState -> STM () enqueueShutdownRequest toPid msg schedulerState =-  view (at toPid) <$> readTVar (schedulerState ^. processTable)-   >>= maybe (return ())-             (\toProcessTable -> do-                modifyTVar' (toProcessTable ^. messageQ ) (shutdownRequests ?~ msg)-                return ())+  view (at toPid) <$> readTVar (schedulerState ^. processTable) >>=+  maybe+    (return ())+    (\toProcessTable -> do+       modifyTVar' (toProcessTable ^. messageQ) (shutdownRequests ?~ msg)+       return ())

src/Control/Eff/Concurrent/Process/Interactive.hs view

@@ -38,7 +38,6 @@ import           Control.Concurrent import           Control.Concurrent.STM import           Control.Eff-import           Control.Eff.Lift import           Control.Eff.Concurrent.Api import           Control.Eff.Concurrent.Api.Client import           Control.Eff.Concurrent.Process

src/Control/Eff/Concurrent/Process/SingleThreadedScheduler.hs view

@@ -6,14 +6,11 @@   , scheduleMonadIOEff   , scheduleIOWithLogging   , defaultMainSingleThreaded-  , singleThreadedIoScheduler   ) where  import           Control.Concurrent             ( yield )-import           Control.DeepSeq import           Control.Eff-import           Control.Eff.Lift import           Control.Eff.Extend import           Control.Eff.Concurrent.Process import           Control.Eff.Log@@ -22,6 +19,7 @@                                                 ) import           Control.Monad                  ( void                                                 , when+                                                , foldM                                                 ) import           Control.Monad.IO.Class import qualified Data.Sequence                 as Seq@@ -34,6 +32,7 @@ import           Data.Foldable import           Data.Monoid import qualified Control.Monad.State.Strict    as State+import Data.Function (fix)  -- ----------------------------------------------------------------------------- --  STS@@ -45,7 +44,7 @@   , _msgQs :: !(Map.Map ProcessId (Seq Dynamic))   , _monitors :: !(Set.Set (MonitorReference, ProcessId))   , _processLinks :: !(Set.Set (ProcessId, ProcessId))-  , _runEff :: (forall a . Eff r a -> m a)+  , _runEff :: forall a . Eff r a -> m a   , _yieldEff :: m ()   } @@ -65,7 +64,7 @@         (foldMap           (\(pid, msgs) ->             Endo (showString "  " . shows pid . showString ": ")-              <> foldMap (\m -> Endo (shows (dynTypeRep m))) (toList msgs)+              <> foldMap (Endo . shows . dynTypeRep) (toList msgs)           )           (sts ^.. msgQs . itraversed . withIndex)         )@@ -84,7 +83,7 @@ incRef sts = (sts ^. nextRef, sts & nextRef %~ (+ 1))  enqueueMsg :: ProcessId -> Dynamic -> STS r m -> STS r m-enqueueMsg toPid msg = msgQs . at toPid . _Just %~ (:|> msg)+enqueueMsg toPid msg = msgQs . ix toPid %~ (:|> msg)  newProcessQ :: Maybe ProcessId -> STS r m -> (ProcessId, STS r m) newProcessQ parentLink sts =@@ -104,35 +103,37 @@  receiveMsg   :: ProcessId -> MessageSelector a -> STS m r -> Maybe (Maybe (a, STS m r))-receiveMsg pid messageSelector sts = case sts ^. msgQs . at pid of-  Nothing   -> Nothing-  Just msgQ -> Just $ case partitionMessages msgQ Empty of+receiveMsg pid messageSelector sts =+  case sts ^. msgQs . at pid of     Nothing -> Nothing-    Just (result, otherMessages) ->-      Just (result, sts & msgQs . at pid . _Just .~ otherMessages)- where-  partitionMessages Empty           _acc = Nothing-  partitionMessages (m :<| msgRest) acc  = maybe-    (partitionMessages msgRest (acc :|> m))-    (\res -> Just (res, acc Seq.>< msgRest))-    (runMessageSelector messageSelector m)+    Just msgQ ->+      Just $+      case partitionMessages msgQ Empty of+        Nothing -> Nothing+        Just (result, otherMessages) -> Just (result, sts & msgQs . ix pid .~ otherMessages)+  where+    partitionMessages Empty _acc = Nothing+    partitionMessages (m :<| msgRest) acc =+      maybe+        (partitionMessages msgRest (acc :|> m))+        (\res -> Just (res, acc Seq.>< msgRest))+        (runMessageSelector messageSelector m)  -- | Add monitor: If the process is dead, enqueue a ProcessDown message into the -- owners message queue addMonitoring   :: ProcessId -> ProcessId -> STS m r -> (MonitorReference, STS m r)-addMonitoring owner target = State.runState $ do-  mi <- State.state incRef-  let mref = MonitorReference mi target-  when (target /= owner) $ do-    pt <- use msgQs-    if Map.member target pt-      then monitors %= Set.insert (mref, owner)-      else-        let pdown =-              (ProcessDown mref (SomeExitReason (ProcessNotRunning target)))-        in  State.modify' (enqueueMsg owner (toDyn pdown))-  return mref+addMonitoring owner target =+  State.runState $ do+    mi <- State.state incRef+    let mref = MonitorReference mi target+    when (target /= owner) $ do+      pt <- use msgQs+      if Map.member target pt+        then monitors %= Set.insert (mref, owner)+        else let pdown = ProcessDown mref (SomeExitReason (ProcessNotRunning target))+              in State.modify' (enqueueMsg owner (toDyn pdown))+    return mref  removeMonitoring :: MonitorReference -> STS m r -> STS m r removeMonitoring mref = monitors %~ Set.filter (\(ref, _) -> ref /= mref)@@ -177,16 +178,16 @@ --  Meat Of The Thing -- ----------------------------------------------------------------------------- --- | Like 'schedule' but /pure/. The @yield@ effect is just @return ()@.+-- | Like 'scheduleIO' but /pure/. The @yield@ effect is just @return ()@. -- @schedulePure == runIdentity . 'scheduleM' (Identity . run)  (return ())@ -- -- @since 0.3.0.2 schedulePure-  :: Eff (InterruptableProcess '[Logs LogMessage]) a+  :: Eff (InterruptableProcess '[Logs, LogWriterReader PureLogWriter]) a   -> Either (ExitReason 'NoRecovery) a-schedulePure e = run (scheduleM ignoreLogs (return ()) e)+schedulePure e = run (scheduleM (withSomeLogging @PureLogWriter) (return ()) e) --- | Invoke 'schedule' with @lift 'Control.Concurrent.yield'@ as yield effect.+-- | Invoke 'scheduleM' with @lift 'Control.Concurrent.yield'@ as yield effect. -- @scheduleIO runEff == 'scheduleM' (runLift . runEff) (liftIO 'yield')@ -- -- @since 0.4.0.0@@ -197,7 +198,7 @@   -> m (Either (ExitReason 'NoRecovery) a) scheduleIO r = scheduleM (runLift . r) (liftIO yield) --- | Invoke 'schedule' with @lift 'Control.Concurrent.yield'@ as yield effect.+-- | Invoke 'scheduleM' with @lift 'Control.Concurrent.yield'@ as yield effect. -- @scheduleMonadIOEff == 'scheduleM' id (liftIO 'yield')@ -- -- @since 0.3.0.2@@ -213,22 +214,22 @@ -- -- Log messages are evaluated strict. ----- @scheduleIOWithLogging == 'run' . 'captureLogs' . 'schedule' (return ())@+-- @scheduleIOWithLogging == 'scheduleIO' . 'withLogging'@ -- -- @since 0.4.0.0 scheduleIOWithLogging-  :: (NFData l)-  => LogWriter l IO-  -> Eff (InterruptableProcess '[Logs l, LogWriterReader l IO, Lift IO]) a+  :: HasCallStack+  => LogWriter IO+  -> Eff (InterruptableProcess LoggingAndIo) a   -> IO (Either (ExitReason 'NoRecovery) a)-scheduleIOWithLogging h = scheduleIO (writeLogs h)+scheduleIOWithLogging h = scheduleIO (withLogging h)  -- | Handle the 'Process' effect, as well as all lower effects using an effect handler function. -- -- Execute the __main__ 'Process' and all the other processes 'spawn'ed by it in the -- current thread concurrently, using a co-routine based, round-robin--- scheduler. If a process exits with 'exitNormally', 'exitWithError',--- 'raiseError' or is killed by another process @Left ...@ is returned.+-- scheduler. If a process exits with eg.g 'exitNormally' or 'exitWithError'+-- or is killed by another process @Left ...@ is returned. -- Otherwise, the result will be wrapped in a @Right@. -- -- Every time a process _yields_ the effects are evaluated down to the a value@@ -328,25 +329,28 @@   => (forall a . Eff r a -> m a)   -> Eff (ConsProcess r) v   -> m (OnYield r v)-runAsCoroutinePure r = r . handle_relay (return . OnDone) cont+runAsCoroutinePure r = r . fix (handle_relay' cont (return . OnDone))  where-  cont :: Process r x -> (x -> Eff r (OnYield r v)) -> Eff r (OnYield r v)-  cont FlushMessages                k  = return (OnFlushMessages k)-  cont YieldProcess                 k  = return (OnYield k)-  cont SelfPid                      k  = return (OnSelf k)-  cont (Spawn     e               ) k  = return (OnSpawn False e k)-  cont (SpawnLink e               ) k  = return (OnSpawn True e k)-  cont (Shutdown  !sr             ) _k = return (OnShutdown sr)-  cont (SendMessage !tp !msg      ) k  = return (OnSend tp msg k)-  cont (ReceiveSelectedMessage f  ) k  = return (OnRecv f k)-  cont (GetProcessState        !tp) k  = return (OnGetProcessState tp k)-  cont (SendInterrupt !tp  !er    ) k  = return (OnSendInterrupt tp er k)-  cont (SendShutdown  !pid !sr    ) k  = return (OnSendShutdown pid sr k)-  cont MakeReference                k  = return (OnMakeReference k)-  cont (Monitor   !pid)             k  = return (OnMonitor pid k)-  cont (Demonitor !ref)             k  = return (OnDemonitor ref k)-  cont (Link      !pid)             k  = return (OnLink pid k)-  cont (Unlink    !pid)             k  = return (OnUnlink pid k)+  cont :: (Eff (ConsProcess r) v -> Eff r (OnYield r v))+       -> Arrs (ConsProcess r) x v+       -> Process r x+       -> Eff r (OnYield r v)+  cont k q FlushMessages                = return (OnFlushMessages (k . qApp q))+  cont k q YieldProcess                 = return (OnYield (k . qApp q))+  cont k q SelfPid                      = return (OnSelf (k . qApp q))+  cont k q (Spawn     e               ) = return (OnSpawn False e (k . qApp q))+  cont k q (SpawnLink e               ) = return (OnSpawn True e (k . qApp q))+  cont _ _ (Shutdown  !sr             ) = return (OnShutdown sr)+  cont k q (SendMessage !tp !msg      ) = return (OnSend tp msg (k . qApp q))+  cont k q (ReceiveSelectedMessage f  ) = return (OnRecv f (k . qApp q))+  cont k q (GetProcessState        !tp) = return (OnGetProcessState tp (k . qApp q))+  cont k q (SendInterrupt !tp  !er    ) = return (OnSendInterrupt tp er (k . qApp q))+  cont k q (SendShutdown  !pid !sr    ) = return (OnSendShutdown pid sr (k . qApp q))+  cont k q MakeReference                = return (OnMakeReference (k . qApp q))+  cont k q (Monitor   !pid)             = return (OnMonitor pid (k . qApp q))+  cont k q (Demonitor !ref)             = return (OnDemonitor ref (k . qApp q))+  cont k q (Link      !pid)             = return (OnLink pid (k . qApp q))+  cont k q (Unlink    !pid)             = return (OnUnlink pid (k . qApp q))  -- | Internal 'Process' handler function. handleProcess@@ -358,207 +362,166 @@   return $ Left (NotRecovered (ProcessError "no main process"))  handleProcess sts allProcs@((!processState, !pid) :<| rest) =-  let handleExit res = if pid == 0-        then return res-        else do-          let (downPids, stsNew) = removeLinksTo pid sts-              linkedPids         = filter (/= pid) downPids-              reason             = LinkedProcessCrashed pid-              unlinkLoop []                ps = return ps-              unlinkLoop (dPid : dPidRest) ps = do-                ps' <- sendInterruptToOtherPid dPid reason ps-                unlinkLoop dPidRest ps'-          let allProcsWithoutPid = Seq.filter (\(_, p) -> p /= pid) rest-          nextTargets <- unlinkLoop linkedPids allProcsWithoutPid-          handleProcess-            (dropMsgQ-              pid-              (triggerAndRemoveMonitor-                pid-                (either SomeExitReason (const (SomeExitReason ExitNormally)) res-                )-                stsNew-              )-            )-            nextTargets-  in-    case processState of-      OnDone     r    -> handleExit (Right r)--      OnShutdown e    -> handleExit (Left e)--      OnInterrupt e k -> do-        nextK <- diskontinue sts k e-        handleProcess sts (rest :|> (nextK, pid))--      OnSendInterrupt targetPid sr k -> doSendInterrupt targetPid sr k--      OnSendShutdown  targetPid sr k -> do-        let allButTarget =-              Seq.filter (\(_, e) -> e /= pid && e /= targetPid) allProcs-            targets = Seq.filter (\(_, e) -> e == targetPid) allProcs-            suicide = targetPid == pid-        if suicide-          then handleExit (Left sr)+  let handleExit res =+        if pid == 0+          then return res           else do-            let deliverTheGoodNews (targetState, tPid) = do-                  nextTargetState <- case targetState of-                    OnSendInterrupt _ _ _tk -> return (OnShutdown sr)-                    OnSendShutdown  _ _ _tk -> return (OnShutdown sr)-                    OnFlushMessages _tk     -> return (OnShutdown sr)-                    OnYield         _tk     -> return (OnShutdown sr)-                    OnSelf          _tk     -> return (OnShutdown sr)-                    OnSend _ _ _tk          -> return (OnShutdown sr)-                    OnRecv _ _tk            -> return (OnShutdown sr)-                    OnSpawn _ _ _tk         -> return (OnShutdown sr)-                    OnDone x                -> return (OnDone x)-                    OnGetProcessState _ _tk -> return (OnShutdown sr)-                    OnShutdown sr'          -> return (OnShutdown sr')-                    OnInterrupt _er _tk     -> return (OnShutdown sr)-                    OnMakeReference _tk     -> return (OnShutdown sr)-                    OnMonitor   _ _tk       -> return (OnShutdown sr)-                    OnDemonitor _ _tk       -> return (OnShutdown sr)-                    OnLink      _ _tk       -> return (OnShutdown sr)-                    OnUnlink    _ _tk       -> return (OnShutdown sr)-                  return (nextTargetState, tPid)-            nextTargets <- _runEff sts $ traverse deliverTheGoodNews targets-            nextK       <- kontinue sts k ()-            handleProcess sts-                          (allButTarget Seq.>< (nextTargets :|> (nextK, pid)))--      OnSelf k -> do-        nextK <- kontinue sts k pid-        handleProcess sts (rest :|> (nextK, pid))--      OnMakeReference k -> do-        let (ref, stsNext) = incRef sts-        nextK <- kontinue sts k ref-        handleProcess stsNext (rest :|> (nextK, pid))--      OnYield k -> do-        sts ^. yieldEff-        nextK <- kontinue sts k ()-        handleProcess sts (rest :|> (nextK, pid))--      OnSend toPid msg k -> do-        nextK <- kontinue sts k ()-        handleProcess (enqueueMsg toPid msg sts) (rest :|> (nextK, pid))--      OnGetProcessState toPid k -> do-        nextK <- kontinue sts k (getProcessState toPid sts)-        handleProcess sts (rest :|> (nextK, pid))--      OnSpawn link f k -> do-        let (newPid, newSts) =-              newProcessQ (if link then Just pid else Nothing) sts-        fk    <- runAsCoroutinePure (newSts ^. runEff) (f >> exitNormally)-        nextK <- kontinue newSts k newPid-        handleProcess newSts (rest :|> (fk, newPid) :|> (nextK, pid))--      OnFlushMessages k -> do-        let (msgs, newSts) = flushMsgs pid sts-        nextK <- kontinue newSts k msgs-        handleProcess newSts (rest :|> (nextK, pid))--      recv@(OnRecv messageSelector k) ->-        case receiveMsg pid messageSelector sts of-          Nothing -> do-            nextK <- diskontinue-              sts-              k-              (ProcessError (show pid ++ " has no message queue"))--            handleProcess sts (rest :|> (nextK, pid))-          Just Nothing -> if Seq.length rest == 0-            then do-              nextK <- diskontinue sts-                                   k-                                   (ProcessError (show pid ++ " deadlocked"))+            let (downPids, stsNew) = removeLinksTo pid sts+                linkedPids = filter (/= pid) downPids+                reason = LinkedProcessCrashed pid+                unlinkLoop dPidRest ps = foldM (\ps' dPid -> sendInterruptToOtherPid dPid reason ps') ps dPidRest+            let allProcsWithoutPid = Seq.filter (\(_, p) -> p /= pid) rest+            nextTargets <- unlinkLoop linkedPids allProcsWithoutPid+            handleProcess+              (dropMsgQ+                 pid+                 (triggerAndRemoveMonitor pid (either SomeExitReason (const (SomeExitReason ExitNormally)) res) stsNew))+              nextTargets+   in case processState of+        OnDone r -> handleExit (Right r)+        OnShutdown e -> handleExit (Left e)+        OnInterrupt e k -> do+          nextK <- diskontinue sts k e+          handleProcess sts (rest :|> (nextK, pid))+        OnSendInterrupt targetPid sr k -> doSendInterrupt targetPid sr k+        OnSendShutdown targetPid sr k -> do+          let allButTarget = Seq.filter (\(_, e) -> e /= pid && e /= targetPid) allProcs+              targets = Seq.filter (\(_, e) -> e == targetPid) allProcs+              suicide = targetPid == pid+          if suicide+            then handleExit (Left sr)+            else do+              let deliverTheGoodNews (targetState, tPid) = do+                    nextTargetState <-+                      case targetState of+                        OnSendInterrupt _ _ _tk -> return (OnShutdown sr)+                        OnSendShutdown _ _ _tk -> return (OnShutdown sr)+                        OnFlushMessages _tk -> return (OnShutdown sr)+                        OnYield _tk -> return (OnShutdown sr)+                        OnSelf _tk -> return (OnShutdown sr)+                        OnSend _ _ _tk -> return (OnShutdown sr)+                        OnRecv _ _tk -> return (OnShutdown sr)+                        OnSpawn _ _ _tk -> return (OnShutdown sr)+                        OnDone x -> return (OnDone x)+                        OnGetProcessState _ _tk -> return (OnShutdown sr)+                        OnShutdown sr' -> return (OnShutdown sr')+                        OnInterrupt _er _tk -> return (OnShutdown sr)+                        OnMakeReference _tk -> return (OnShutdown sr)+                        OnMonitor _ _tk -> return (OnShutdown sr)+                        OnDemonitor _ _tk -> return (OnShutdown sr)+                        OnLink _ _tk -> return (OnShutdown sr)+                        OnUnlink _ _tk -> return (OnShutdown sr)+                    return (nextTargetState, tPid)+              nextTargets <- _runEff sts $ traverse deliverTheGoodNews targets+              nextK <- kontinue sts k ()+              handleProcess sts (allButTarget Seq.>< (nextTargets :|> (nextK, pid)))+        OnSelf k -> do+          nextK <- kontinue sts k pid+          handleProcess sts (rest :|> (nextK, pid))+        OnMakeReference k -> do+          let (ref, stsNext) = incRef sts+          nextK <- kontinue sts k ref+          handleProcess stsNext (rest :|> (nextK, pid))+        OnYield k -> do+          sts ^. yieldEff+          nextK <- kontinue sts k ()+          handleProcess sts (rest :|> (nextK, pid))+        OnSend toPid msg k -> do+          nextK <- kontinue sts k ()+          handleProcess (enqueueMsg toPid msg sts) (rest :|> (nextK, pid))+        OnGetProcessState toPid k -> do+          nextK <- kontinue sts k (getProcessState toPid sts)+          handleProcess sts (rest :|> (nextK, pid))+        OnSpawn link f k -> do+          let (newPid, newSts) =+                newProcessQ+                  (if link+                     then Just pid+                     else Nothing)+                  sts+          fk <- runAsCoroutinePure (newSts ^. runEff) (f >> exitNormally)+          nextK <- kontinue newSts k newPid+          handleProcess newSts (rest :|> (fk, newPid) :|> (nextK, pid))+        OnFlushMessages k -> do+          let (msgs, newSts) = flushMsgs pid sts+          nextK <- kontinue newSts k msgs+          handleProcess newSts (rest :|> (nextK, pid))+        recv@(OnRecv messageSelector k) ->+          case receiveMsg pid messageSelector sts of+            Nothing -> do+              nextK <- diskontinue sts k (ProcessError (show pid ++ " has no message queue"))               handleProcess sts (rest :|> (nextK, pid))-            else handleProcess sts (rest :|> (recv, pid))-          Just (Just (result, newSts)) -> do-            nextK <- kontinue newSts k result-            handleProcess newSts (rest :|> (nextK, pid))--      OnMonitor toPid k -> do-        let (ref, stsNew) = addMonitoring pid toPid sts-        nextK <- kontinue stsNew k ref-        handleProcess stsNew (rest :|> (nextK, pid))--      OnDemonitor monRef k -> do-        let stsNew = removeMonitoring monRef sts-        nextK <- kontinue stsNew k ()-        handleProcess stsNew (rest :|> (nextK, pid))--      OnLink toPid k -> do-        let (downInterrupts, stsNew) = addLink pid toPid sts-        nextK <- case downInterrupts of-          Nothing -> kontinue stsNew k ()-          Just i  -> diskontinue stsNew k i-        handleProcess stsNew (rest :|> (nextK, pid))--      OnUnlink toPid k -> do-        let (_, stsNew) = removeLinksTo toPid sts-        nextK <- kontinue stsNew k ()-        handleProcess stsNew (rest :|> (nextK, pid))- where-  doSendInterrupt targetPid sr k = do-    let suicide = targetPid == pid-    if suicide-      then do-        nextK <- diskontinue sts k sr-        handleProcess sts (rest :|> (nextK, pid))-      else do-        nextTargets <- sendInterruptToOtherPid targetPid sr rest-        nextK       <- kontinue sts k ()-        handleProcess sts (nextTargets :|> (nextK, pid))--  sendInterruptToOtherPid targetPid sr procs = do-    let allButTarget = Seq.filter (\(_, e) -> e /= targetPid) procs-        targets      = Seq.filter (\(_, e) -> e == targetPid) procs-        deliverTheGoodNews (targetState, tPid) = do-          nextTargetState <- case targetState of-            OnSendInterrupt _ _ tk -> tk (Interrupted sr)-            OnSendShutdown  _ _ tk -> tk (Interrupted sr)-            OnFlushMessages tk     -> tk (Interrupted sr)-            OnYield         tk     -> tk (Interrupted sr)-            OnSelf          tk     -> tk (Interrupted sr)-            OnSend _ _ tk          -> tk (Interrupted sr)-            OnRecv _ tk            -> tk (Interrupted sr)-            OnSpawn _ _ tk         -> tk (Interrupted sr)-            OnDone x               -> return (OnDone x)-            OnGetProcessState _ tk -> tk (Interrupted sr)-            OnShutdown sr'         -> return (OnShutdown sr')-            OnInterrupt er tk      -> tk (Interrupted er)-            OnMakeReference tk     -> tk (Interrupted sr)-            OnMonitor   _ tk       -> tk (Interrupted sr)-            OnDemonitor _ tk       -> tk (Interrupted sr)-            OnLink      _ tk       -> tk (Interrupted sr)-            OnUnlink    _ tk       -> tk (Interrupted sr)-          return (nextTargetState, tPid)-    nextTargets <- _runEff sts $ traverse deliverTheGoodNews targets-    return (nextTargets Seq.>< allButTarget)---- | The concrete list of 'Eff'ects for running this pure scheduler on @IO@ and--- with string logging.-type LoggingAndIo = '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO]---- | A 'SchedulerProxy' for 'LoggingAndIo'.-singleThreadedIoScheduler :: SchedulerProxy LoggingAndIo-singleThreadedIoScheduler = SchedulerProxy+            Just Nothing ->+              if Seq.length rest == 0+                then do+                  nextK <- diskontinue sts k (ProcessError (show pid ++ " deadlocked"))+                  handleProcess sts (rest :|> (nextK, pid))+                else handleProcess sts (rest :|> (recv, pid))+            Just (Just (result, newSts)) -> do+              nextK <- kontinue newSts k result+              handleProcess newSts (rest :|> (nextK, pid))+        OnMonitor toPid k -> do+          let (ref, stsNew) = addMonitoring pid toPid sts+          nextK <- kontinue stsNew k ref+          handleProcess stsNew (rest :|> (nextK, pid))+        OnDemonitor monRef k -> do+          let stsNew = removeMonitoring monRef sts+          nextK <- kontinue stsNew k ()+          handleProcess stsNew (rest :|> (nextK, pid))+        OnLink toPid k -> do+          let (downInterrupts, stsNew) = addLink pid toPid sts+          nextK <-+            case downInterrupts of+              Nothing -> kontinue stsNew k ()+              Just i -> diskontinue stsNew k i+          handleProcess stsNew (rest :|> (nextK, pid))+        OnUnlink toPid k -> do+          let (_, stsNew) = removeLinksTo toPid sts+          nextK <- kontinue stsNew k ()+          handleProcess stsNew (rest :|> (nextK, pid))+  where+    doSendInterrupt targetPid sr k = do+      let suicide = targetPid == pid+      if suicide+        then do+          nextK <- diskontinue sts k sr+          handleProcess sts (rest :|> (nextK, pid))+        else do+          nextTargets <- sendInterruptToOtherPid targetPid sr rest+          nextK <- kontinue sts k ()+          handleProcess sts (nextTargets :|> (nextK, pid))+    sendInterruptToOtherPid targetPid sr procs = do+      let allButTarget = Seq.filter (\(_, e) -> e /= targetPid) procs+          targets = Seq.filter (\(_, e) -> e == targetPid) procs+          deliverTheGoodNews (targetState, tPid) = do+            nextTargetState <-+              case targetState of+                OnSendInterrupt _ _ tk -> tk (Interrupted sr)+                OnSendShutdown _ _ tk -> tk (Interrupted sr)+                OnFlushMessages tk -> tk (Interrupted sr)+                OnYield tk -> tk (Interrupted sr)+                OnSelf tk -> tk (Interrupted sr)+                OnSend _ _ tk -> tk (Interrupted sr)+                OnRecv _ tk -> tk (Interrupted sr)+                OnSpawn _ _ tk -> tk (Interrupted sr)+                OnDone x -> return (OnDone x)+                OnGetProcessState _ tk -> tk (Interrupted sr)+                OnShutdown sr' -> return (OnShutdown sr')+                OnInterrupt er tk -> tk (Interrupted er)+                OnMakeReference tk -> tk (Interrupted sr)+                OnMonitor _ tk -> tk (Interrupted sr)+                OnDemonitor _ tk -> tk (Interrupted sr)+                OnLink _ tk -> tk (Interrupted sr)+                OnUnlink _ tk -> tk (Interrupted sr)+            return (nextTargetState, tPid)+      nextTargets <- _runEff sts $ traverse deliverTheGoodNews targets+      return (nextTargets Seq.>< allButTarget) --- | Execute a 'Process' using 'schedule' on top of 'Lift' @IO@ and 'Logs'+-- | Execute a 'Process' using 'scheduleM' on top of 'Lift' @IO@ and 'withLogging' -- @String@ effects.-defaultMainSingleThreaded-  :: HasCallStack-  => Eff-       ( InterruptableProcess-           '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO]-       )-       ()-  -> IO ()+defaultMainSingleThreaded :: HasCallStack => Eff (InterruptableProcess LoggingAndIo) () -> IO () defaultMainSingleThreaded =   void     . runLift-    . writeLogs (multiMessageLogWriter ($ printLogMessage))+    . withLogging consoleLogWriter     . scheduleMonadIOEff

src/Control/Eff/Concurrent/Process/Timer.hs view

@@ -20,7 +20,6 @@  import           Control.Eff.Concurrent.Process import           Control.Concurrent-import           Control.Eff.Lift import           Control.Eff import           Control.DeepSeq import           Control.Monad.IO.Class

src/Control/Eff/ExceptionExtra.hs view

@@ -4,7 +4,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-}--- | Add-ons to 'Control.Eff.Exception' and 'Control.Excepion'+-- | Add-ons to 'Control.Eff.Exception' and 'Control.Exception' module Control.Eff.ExceptionExtra   ( liftTry   , maybeThrow@@ -16,7 +16,6 @@ import qualified Control.Monad.Catch           as Catch import           Control.Eff import           Control.Eff.Extend-import           Control.Eff.Lift import           Control.Eff.Exception         as Eff import           GHC.Stack import           Control.Eff.Reader.Lazy       as Lazy

src/Control/Eff/Log.hs view

@@ -1,11 +1,212 @@--- | A logging effect based on 'Control.Monad.Log.MonadLog'.+-- | A logging effect.+--+-- There is just one log message type: 'LogMessage' and it is written using 'logMsg' and+-- the functions built on top of it.+--+-- The 'Logs' effect is tightly coupled with the 'LogWriterReader' effect.+-- When using the 'Control.Monad.Trans.ControlMonadBaseControl' instance, the underlying monad of the 'LogWriter',+-- that is expected to be present through the respective 'LogWriterReader', is+-- constrained to be the base monad itself, e.g. 'IO'.+--+-- The log message type is fixed to 'LogMessage', and there is a type class for+-- converting to that, call 'ToLogMessage'.+--+-- There is a single global 'LogPredicate' that can be used to suppress logs directly+-- at the point where they are sent, in the 'logMsg' function.+--+-- Note that all logging is eventually done via 'logMsg'; 'logMsg' is the __only__ place where+-- log filtering should happen.+--+-- Also, 'LogMessage's are evaluated using 'Control.DeepSeq.deepseq', __after__ they pass the 'LogPredicate', also inside 'logMsg'.+--+-- Example:+--+-- > exampleLogging :: IO ()+-- > exampleLogging =+-- >     runLift+-- >   $ withLogging consoleLogWriter+-- >   $ do+-- >       logDebug "test 1.1"+-- >       logError "test 1.2"+-- >       censorLogs (prefixLogMessagesWith "NESTED: ")+-- >        $ do+-- >             addLogWriter debugTraceLogWriter+-- >              $ setLogPredicate (\m -> (view lmMessage m) /= "not logged")+-- >              $ do+-- >                   logInfo "not logged"+-- >                   logMsg "test 2.1"+-- >             logWarning "test 2.2"+-- >       logCritical "test 1.3"+--+-- == Asynchronous Logging+--+-- Logging in a 'Control.Concurrent.Async.withAsync' spawned thread is done using 'withAsyncLogging'.+--+-- == 'LogPredicate's+--+-- See "Control.Eff.Log.Handler#LogPredicate" module Control.Eff.Log-  ( module Control.Eff.Log.Handler-  , module Control.Eff.Log.Channel+  ( -- * Module Re-Exports+    -- | This module contains the API for __sending__ log messages and for+    -- handling the messages in the frame work of extensible effects.+    --+    -- It also defines the reader effect to access 'LogWriter's+    module Control.Eff.Log.Handler+    -- | The module that contains the 'LogMessage' and 'LogPredicate' definitions.+    --+    -- The log message type corresponds to RFC-5424, including structured data.   , module Control.Eff.Log.Message+    -- | This module only exposes a 'LogWriter' for asynchronous logging;+  , module Control.Eff.Log.Channel+    -- | This module defines the 'LogWriter' type, which is used to give+    -- callback functions for log messages an explicit type.+  , module Control.Eff.Log.Writer+  -- * Example Code for Logging+  , exampleLogging+  , exampleWithLogging+  , exampleWithSomeLogging+  , exampleLogPredicate+  , exampleLogCapture+  , exampleAsyncLogging   ) where -import           Control.Eff.Log.Handler import           Control.Eff.Log.Channel+import           Control.Eff.Log.Handler import           Control.Eff.Log.Message+import           Control.Eff.Log.Writer++import           Control.Eff+import           Control.Lens (view, (%~), to)+++-- * Logging examples++-- | Example code for:+--+--  * 'withConsoleLogging'+--  * 'ioLogWriter'+--  * 'printLogMessage'+--  * 'logDebug'+--  * 'logError'+--  * 'prefixLogMessagesWith'+--  * 'addLogWriter'+--  * 'debugTraceLogWriter'+--  * 'setLogPredicate'+--  * 'logInfo'+--  * 'logMsg'+--  * 'logWarning'+--  * 'logCritical'+--  * 'lmMessage'+exampleLogging :: IO ()+exampleLogging =+    runLift+  $ withConsoleLogging "my-app" local7 allLogMessages+  $ do+      logDebug "test 1.1"+      logError "test 1.2"+      censorLogs (prefixLogMessagesWith "NESTED: ")+       $ do+            addLogWriter debugTraceLogWriter+             $ setLogPredicate (\m -> (view lmMessage m) /= "not logged")+             $ do+                  logInfo "not logged"+                  logMsg "test 2.1"+            logWarning "test 2.2"+      logCritical "test 1.3"++-- | Example code for:+--+--  * 'withLogging'+--  * 'consoleLogWriter'+exampleWithLogging :: IO ()+exampleWithLogging =+    runLift+  $ withLogging consoleLogWriter+  $ logDebug "Oh, hi there"++-- | Example code for:+--+--  * 'withSomeLogging'+--  * 'PureLogWriter'+--  * 'logDebug'+exampleWithSomeLogging :: ()+exampleWithSomeLogging =+    run+  $ withSomeLogging @PureLogWriter+  $ logDebug "Oh, hi there"++-- | Example code for:+--+--  * 'setLogPredicate'+--  * 'modifyLogPredicate'+--  * 'lmMessageStartsWith'+--  * 'lmSeverityIs'+--  * 'lmSeverityIsAtLeast'+--  * 'includeLogMessages'+--  * 'excludeLogMessages'+exampleLogPredicate :: IO Int+exampleLogPredicate =+    runLift+  $ withSomeLogging @IO+  $ setLogWriter consoleLogWriter+  $ do logMsg "test"+       setLogPredicate (lmMessageStartsWith "OMG")+                         (do logMsg "this message will not be logged"+                             logMsg "OMG logged"+                             modifyLogPredicate (\p lm -> p lm || lmSeverityIs errorSeverity lm) $ do+                               logDebug "OMG logged"+                               logInfo "Not logged"+                               logError "Logged"+                               logEmergency "Not Logged"+                               includeLogMessages (lmSeverityIsAtLeast warningSeverity) $ do+                                 logInfo "Not logged"+                                 logError "Logged"+                                 logEmergency "Logged"+                                 logWarning "Logged"+                                 logDebug "OMG still Logged"+                                 excludeLogMessages (lmMessageStartsWith "OMG") $ do+                                   logDebug "OMG NOT Logged"+                                   logError "OMG ALSO NOT Logged"+                                   logEmergency "Still Logged"+                                   logWarning "Still Logged"+                                 logWarning "Logged"+                                 logDebug "OMG still Logged"+                             return 42)++-- | Example code for:+--+--  * 'runCapturedLogsWriter'+--  * 'listLogWriter'+--  * 'mappingLogWriter'+--  * 'filteringLogWriter'+exampleLogCapture :: IO ()+exampleLogCapture = go >>= putStrLn+ where go = fmap (unlines . map renderLogMessage . snd)+              $  runLift+              $  runCapturedLogsWriter+              $  withLogging listLogWriter+              $  addLogWriter (mappingLogWriter (lmMessage %~ ("CAPTURED "++)) listLogWriter)+              $  addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("TRACED "++)) debugTraceLogWriter))+              $  do+                    logEmergency "test emergencySeverity 1"+                    logCritical "test criticalSeverity 2"+                    logAlert "test alertSeverity 3"+                    logError "test errorSeverity 4"+                    logWarning "test warningSeverity 5"+                    logInfo "test informationalSeverity 6"+                    logDebug "test debugSeverity 7"+       testPred = view (lmSeverity . to (<= errorSeverity))+++-- | Example code for:+--+--  * 'withAsyncLogging'+exampleAsyncLogging :: IO ()+exampleAsyncLogging =+    runLift+  $ withSomeLogging @IO+  $ withAsyncLogging (1000::Int) consoleLogWriter+  $ do logMsg "test 1"+       logMsg "test 2"+       logMsg "test 3"

src/Control/Eff/Log/Channel.hs view

@@ -1,101 +1,88 @@--- | Concurrent Logging+-- | Asynchronous Logging module Control.Eff.Log.Channel-  ( LogChannel()-  , withAsyncLogChannel-  , handleLoggingAndIO-  , handleLoggingAndIO_-  )-where+  ( withAsyncLogging+  ) where -import           Control.Concurrent.Async-import           Control.Concurrent.STM-import           Control.Eff                   as Eff-import           Control.Eff.Lift-import           Control.Exception              ( evaluate )-import           Control.Monad                  ( void-                                                , unless-                                                )-import           Control.Eff.Log.Handler-import           Data.Foldable                  ( traverse_ )-import           Data.Kind                      ( )-import           Control.DeepSeq-import           GHC.Stack+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.DeepSeq+import Control.Eff as Eff+import Control.Eff.Log.Handler+import Control.Eff.Log.Message+import Control.Eff.Log.Writer+import Control.Exception (evaluate)+import Control.Monad (unless)+import Control.Monad.Trans.Control (MonadBaseControl, liftBaseOp)+import Data.Foldable (traverse_)+import Data.Kind ()  -- | 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.+-- on a message queue, to which all log message will be relayed. --+-- If an exception is received, the logging process will be killed.+-- -- Log messages are deeply evaluated before being sent to the logger process, -- to prevent that lazy evaluation leads to heavy work being done in the -- logger process instead of the caller process. ----- Example usage, a super stupid log to file:+-- Example: ----- >--- > main =--- >   withAsyncLogChannel--- >      1000--- >      (singleMessageLogWriter putStrLn)--- >      (handleLoggingAndIO--- >        (do logMsg "test 1"--- >            logMsg "test 2"--- >            logMsg "test 3"))+-- > exampleAsyncLogging :: IO ()+-- > exampleAsyncLogging =+-- >     runLift+-- >   $ withSomeLogging @IO+-- >   $ withAsyncLogging (1000::Int) consoleLogWriter+-- >   $ do logMsg "test 1"+-- >        logMsg "test 2"+-- >        logMsg "test 3" -- > ---withAsyncLogChannel-  :: forall message a len-   . (NFData message, Integral len)+withAsyncLogging ::+     ( LogsTo IO e+     , Lifted IO e+     , MonadBaseControl IO (Eff e)+     , Integral len+     )   => len -- ^ Size of the log message input queue. If the queue is full, message          -- are dropped silently.-  -> LogWriter message IO -- ^ An IO action to write the log messages-  -> (LogChannel message -> IO a)+  -> LogWriter IO+  -> Eff e a+  -> Eff e a+withAsyncLogging queueLength lw e =+  liftBaseOp+    (withAsyncLogChannel queueLength (runLogWriter lw . force))+    (\lc -> setLogWriter (makeLogChannelWriter lc) e)++withAsyncLogChannel ::+     forall a len. (Integral len)+  => len+  -> (LogMessage -> IO ())+  -> (LogChannel -> IO a)   -> IO a withAsyncLogChannel queueLen ioWriter action = do   msgQ <- newTBQueueIO (fromIntegral queueLen)   withAsync (logLoop msgQ) (action . ConcurrentLogChannel msgQ)- where-  logLoop tq = do-    ms <- atomically $ do-      h <- readTBQueue tq-      t <- flushTBQueue tq-      return (h : t)-    writeAllLogMessages ioWriter ms-    logLoop tq---- | Fork an IO based log writer thread and set the 'LogWriter' to an action--- that will send all logs to that thread via a bounded queue.--- When the queue is full, flush it-handleLoggingAndIO-  :: (NFData m, HasCallStack)-  => Eff '[Logs m, LogWriterReader m IO, Lift IO] a-  -> LogChannel m-  -> IO a-handleLoggingAndIO e lc = runLift-  (writeLogs (foldingLogWriter (traverse_ logChannelPutIO)) e)- where-  logQ = fromLogChannel lc-  logChannelPutIO (force -> me) = do-    !m <- evaluate me-    atomically-      (do-        dropMessage <- isFullTBQueue logQ-        unless dropMessage (writeTBQueue logQ m)-      )+  where+    logLoop tq = do+      ms <-+        atomically $ do+          h <- readTBQueue tq+          t <- flushTBQueue tq+          return (h : t)+      traverse_ ioWriter ms+      logLoop tq --- | Like 'handleLoggingAndIO' but return @()@.-handleLoggingAndIO_-  :: (NFData m, HasCallStack)-  => Eff '[Logs m, LogWriterReader m IO, Lift IO] a-  -> LogChannel m-  -> IO ()-handleLoggingAndIO_ e lc = void (handleLoggingAndIO e lc)+makeLogChannelWriter :: LogChannel -> LogWriter IO+makeLogChannelWriter lc = ioLogWriter logChannelPutIO+  where+    logChannelPutIO (force -> me) = do+      !m <- evaluate me+      atomically+        (do dropMessage <- isFullTBQueue logQ+            unless dropMessage (writeTBQueue logQ m))+    logQ = fromLogChannel lc --- | 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 =-   ConcurrentLogChannel-   { fromLogChannel :: TBQueue message-   , _logChannelThread :: Async ()-   }-   -- ^ send all log messages to a log process+data LogChannel = ConcurrentLogChannel+  { fromLogChannel :: TBQueue LogMessage+  , _logChannelThread :: Async ()+  }

src/Control/Eff/Log/Handler.hs view

@@ -1,430 +1,732 @@--- | A logging effect based on 'Control.Monad.Log.MonadLog'.+{-# LANGUAGE UndecidableInstances #-}+-- | A memory efficient, streaming, logging effect with support for+-- efficiently not logging when no logs are required.+--+-- Good support for logging to a file or to the network,+-- as well as asynchronous logging in another thread. module Control.Eff.Log.Handler-  ( logMsg-  , logMsgs-  , HasLogWriter-  , mapLogMessages-  , filterLogMessages-  , traverseLogMessages-  , changeLogWriter-  , ignoreLogs-  , traceLogs-  , LogWriter()+  ( -- * Logging API+    -- ** Sending Log Messages+    logMsg+  , logWithSeverity+  , logEmergency+  , logAlert+  , logCritical+  , logError+  , logWarning+  , logNotice+  , logInfo+  , logDebug++  -- ** Log Message Pre-Filtering #LogPredicate#+  -- $LogPredicate+  , includeLogMessages+  , excludeLogMessages+  , setLogPredicate+  , modifyLogPredicate+  , askLogPredicate++  -- * Log Handling API++  -- ** Writing Logs   , LogWriterReader-  , foldingLogWriter-  , writeAllLogMessages-  , singleMessageLogWriter-  , multiMessageLogWriter+  , setLogWriter+  , addLogWriter+  -- *** Log Message Modification+  , withLogFileAppender+  , censorLogs+  , censorLogsM   , askLogWriter+  , modifyLogWriter++  -- ** 'Logs' Effect Handling   , Logs()-  , writeLogs+  , LogsTo+  , withConsoleLogging+  , withIoLogging+  , withLogging+  , withSomeLogging+  , LoggingAndIo+  -- ** Low-Level API for Custom Extensions+  -- *** Log Message Interception   , runLogs+  , respondToLogMessage+  , interceptLogMessages+  -- *** LogWriter Handling+  , runLogWriterReader+   ) 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           Control.Eff.Log.Message+import           Control.Eff.Log.Writer import qualified Control.Exception.Safe        as Safe-import           Data.Foldable                  ( traverse_ )-import           Data.Default-import           Control.Monad+import           Control.Lens+import           Control.Monad                   ( when, (>=>) )+import           Control.Monad.Base              ( MonadBase() ) import qualified Control.Monad.Catch           as Catch-import           Control.Monad.Trans.Control    ( MonadBaseControl-                                                  ( restoreM-                                                  , liftBaseWith-                                                  , StM-                                                  )+import           Control.Monad.Trans.Control     ( MonadBaseControl+                                                   ( restoreM+                                                   , liftBaseWith+                                                   , StM+                                                   )+                                                   , liftBaseOp+                                                 )+import           Data.Default+import           Data.Function                  ( fix )+import           GHC.Stack                      ( HasCallStack+                                                , callStack+                                                , withFrozenCallStack                                                 )-import           Control.Monad.Base             ( MonadBase() )-import           Debug.Trace+import qualified System.IO                     as IO+import           System.Directory               ( canonicalizePath+                                                , createDirectoryIfMissing+                                                )+import           System.FilePath                ( takeDirectory ) --- * 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]+-- | This effect sends 'LogMessage's and is a reader for a 'LogPredicate'.+--+-- Logs are sent via 'logMsg';+-- for more informaion about log predicates, see "Control.Eff.Log.Handler#LogPredicate"+--+-- This effect is handled via 'withLogging'.+data Logs v where+  AskLogFilter+    :: Logs LogPredicate+  WriteLogMessage+    :: !LogMessage -> Logs () --- | 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 (f m)-     , NFData m-     , Member (Logs m) e-     )-  => f m-  -> Eff e ()-logMsgs !msgs = rnf1 msgs `seq` do-  f <- send AskLogFilter-  send-    (LogMsgs-      (do-        m <- msgs-        maybe mzero (return . force) (f m)+instance forall e a k. Handle Logs e a (LogPredicate -> k) where+  handle h q AskLogFilter p         = h (q ^$ p ) p+  handle h q (WriteLogMessage _) p  = h (q ^$ ()) p++-- | This instance allows lifting to the 'Logs' effect, they do, however, need a+-- 'LogWriter' in the base monad, in order to be able to handle 'logMsg' invocations.+--+-- The 'LogWriterReader' effect is must be available to get to the 'LogWriter'.+--+-- Otherwise there is no way to preserve to log messages.+instance forall m e. (MonadBase m m, LiftedBase m e, SupportsLogger m (Logs ': e), SetMember LogWriterReader (LogWriterReader m) (Logs ': e))+  => MonadBaseControl m (Eff (Logs ': e)) where+    type StM (Eff (Logs ': e)) a =  StM (Eff e) a+    liftBaseWith f = do+      lf <- askLogPredicate+      raise (liftBaseWith (\runInBase -> f (runInBase . runLogs @m lf)))+    restoreM = raise . restoreM++instance (LiftedBase m e, Catch.MonadThrow (Eff e))+  => Catch.MonadThrow (Eff (Logs ': e)) where+  throwM exception = raise (Catch.throwM exception)++instance (Applicative m, LiftedBase m e, Catch.MonadCatch (Eff e), SupportsLogger m (Logs ': e), SetMember LogWriterReader (LogWriterReader m) (Logs ': e))+  => Catch.MonadCatch (Eff (Logs ': e)) where+  catch effect handler = do+    lf <- askLogPredicate+    let lower                   = runLogs @m lf+        nestedEffects           = lower effect+        nestedHandler exception = lower (handler exception)+    raise (Catch.catch nestedEffects nestedHandler)++instance (Applicative m, LiftedBase m e, Catch.MonadMask (Eff e), SupportsLogger m (Logs ': e), SetMember LogWriterReader (LogWriterReader m) (Logs ': e))+  => Catch.MonadMask (Eff (Logs ': e)) where+  mask maskedEffect = do+    lf <- askLogPredicate+    let+      lower :: Eff (Logs ': e) a -> Eff e a+      lower = runLogs @m lf+    raise+        (Catch.mask+          (\nestedUnmask -> lower+            (maskedEffect+              ( raise . nestedUnmask . lower )+            )+          )+        )+  uninterruptibleMask maskedEffect = do+    lf <- askLogPredicate+    let+      lower :: Eff (Logs ': e) a -> Eff e a+      lower = runLogs @m lf+    raise+        (Catch.uninterruptibleMask+          (\nestedUnmask -> lower+            (maskedEffect+              ( raise . nestedUnmask . lower )+            )+          )+        )+  generalBracket acquire release useIt = do+    lf <- askLogPredicate+    let+      lower :: Eff (Logs ': e) a -> Eff e a+      lower = runLogs @m lf+    raise+        (Catch.generalBracket+          (lower acquire)+          (((.).(.)) lower release)+          (lower . useIt)       )-    ) --- ** Filter and Transform Log Messages --- | Map a pure function over log messages.-mapLogMessages-  :: forall m r b-   . (NFData m, Member (Logs m) r)-  => (m -> m)-  -> Eff r b-  -> Eff r b-mapLogMessages f eff = do-  old <- send AskLogFilter-  interpose return (go (fmap f . old)) eff- where-  go :: (m -> Maybe m) -> Logs m a -> Arr r a b -> Eff r b-  go t AskLogFilter k = k t-  go _ (LogMsgs ms) k = logMsgs ms >>= k+-- | A constraint alias for effects that requires a 'LogWriterReader', as well as that the+-- contained 'LogWriterReader' has a 'SupportsLogger' instance.+--+-- The requirements of this constraint are provided by:+-- * 'withStdOutLogging'+-- * 'withIoLogging'+-- * 'withLogging'+-- * 'withSomeLogging'+--+type LogsTo h e = (Member Logs e, SupportsLogger h e, SetMember LogWriterReader (LogWriterReader h) e) --- | Keep only those messages, for which a predicate holds.+-- | Enable logging to @stdout@ using the 'defaultIoLogWriter' in combination with+-- the 'consoleLogWriter'. ----- E.g. to keep only messages which begin with @"OMG"@:+-- Example: ----- > filterLogMessages (\msg -> case msg of--- >                             'O':'M':'G':_ -> True--- >                              _            -> False)--- >                   (do logMsg "this message will not be logged"--- >                       logMsg "OMG logged")-filterLogMessages-  :: forall m r b-   . (NFData m, Member (Logs m) r)-  => (m -> Bool)-  -> Eff r b-  -> Eff r b-filterLogMessages predicate eff = do-  old <- send AskLogFilter-  interpose return (go (\m -> if predicate m then old m else Nothing)) eff- where-  go :: (m -> Maybe m) -> Logs m a -> Arr r a b -> Eff r b-  go t AskLogFilter k = k t-  go _ (LogMsgs ms) k = logMsgs ms >>= k+-- > exampleWithConsoleLogging :: IO ()+-- > exampleWithConsoleLogging =+-- >     runLift+-- >   $ withConsoleLogging "my-app" local7 allLogMessages+-- >   $ logInfo "Oh, hi there"+--+-- To vary the 'LogWriter' use 'withIoLogging'.+withConsoleLogging+  :: SetMember Lift (Lift IO) e+  => String+  -> Facility+  -> LogPredicate+  -> Eff (Logs : LogWriterReader IO : e) a+  -> Eff e a+withConsoleLogging = withIoLogging consoleLogWriter --- interpose return go---  where---   go :: Logs m a -> Arr r a b -> Eff r b-  -- go (LogMsgs ms) k = logMsgs (mfilter predicate ms) >>= k+-- | Enable logging to IO using the 'defaultIoLogWriter'.+--+-- To log to the console (standard output), one can use 'withConsoleLogging'.+--+-- Example:+--+-- > exampleWithIoLogging :: IO ()+-- > exampleWithIoLogging =+-- >     runLift+-- >   $ withIoLogging consoleLogWriter+--                     "my-app"+--                     local7+--                     (lmSeverityIsAtLeast informationalSeverity)+-- >   $ logInfo "Oh, hi there"+--+withIoLogging+  :: SetMember Lift (Lift IO) e+  => LogWriter IO+  -> String+  -> Facility+  -> LogPredicate+  -> Eff (Logs : LogWriterReader IO : e) a+  -> Eff e a+withIoLogging lw appName facility defaultPredicate =+    withLogging (defaultIoLogWriter appName facility lw)+  . setLogPredicate defaultPredicate --- ** Filter and Transform Log Messages effectfully+-- | Handle the 'Logs' and 'LogWriterReader' effects.+--+-- It installs the given 'LogWriter', which determines the underlying+-- 'LogWriter' type parameter.+--+-- Example:+--+-- > exampleWithLogging :: IO ()+-- > exampleWithLogging =+-- >     runLift+-- >   $ withLogging consoleLogWriter+-- >   $ logDebug "Oh, hi there"+--+withLogging ::+     forall h e a. (Applicative h, LogsTo h (Logs ': LogWriterReader h ': e))+  => LogWriter h -> Eff (Logs ': LogWriterReader h ': e) a -> Eff e a+withLogging lw = runLogWriterReader lw . runLogs allLogMessages --- | Map an 'Eff'ectful function over every bunch of log messages.+-- | Handles the 'Logs' and 'LogWriterReader' effects. ----- For example, to attach the current time to each log message:+-- By default it uses the 'noOpLogWriter', but using 'setLogWriter' the+-- 'LogWriter' can be replaced. ----- > appendTimestamp--- >  :: ( Member (Logs String) e--- >     , Lifted IO e)--- >  => Eff e a--- >  -> Eff e a--- > appendTimestamp = traverseLogMessages $ \ms -> do--- >   now <- getCurrentTime--- >   return (fmap (show now ++) ms)-traverseLogMessages-  :: forall m r h b-   . ( Member (Logs m) r-     , Monad h-     , Lifted h r-     , Member (Reader (LogWriter m h)) r-     )-  => (forall f . (MonadPlus f, Traversable f, NFData1 f) => f m -> h (f m))-  -> Eff r b-  -> Eff r b-traverseLogMessages f = changeLogWriter-  (\msgs -> do-    lw    <- ask-    msgs' <- lift (f msgs)-    lift (runLogWriter lw msgs')-  )+-- This is like 'withLogging' applied to 'noOpLogWriter'+--+-- Example:+--+-- > exampleWithSomeLogging :: ()+-- > exampleWithSomeLogging =+-- >     run+-- >   $ withSomeLogging @PureLogWriter+-- >   $ logDebug "Oh, hi there"+--+withSomeLogging ::+     forall h e a.+     (Applicative h, LogsTo h (Logs ': LogWriterReader h ': e))+  => Eff (Logs ': LogWriterReader h ': e) a+  -> Eff e a+withSomeLogging = withLogging (noOpLogWriter @h) --- ** Change the Log Writer+-- | The concrete list of 'Eff'ects for logging with an IO based 'LogWriter', and a 'LogWriterReader'.+type LoggingAndIo = '[Logs, LogWriterReader IO, Lift IO] --- | 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+-- | Raw handling of the 'Logs' effect.+-- Exposed for custom extensions, if in doubt use 'withLogging'.+runLogs+  :: forall h e b .+     (LogsTo h (Logs ': e), SupportsLogger h (Logs ': e))+  => LogPredicate+  -> Eff (Logs ': e) b+  -> Eff e b+runLogs p m =+  fix (handle_relay (\a _ -> return a)) (sendLogMessageToLogWriter  m) p --- * Handle Log Messages+-- | Log a message.+--+-- All logging goes through this function.+--+-- This function is the only place where the 'LogPredicate' is applied.+--+-- Also, 'LogMessage's are evaluated using 'deepseq', __after__ they pass the 'LogPredicate'.+logMsg :: forall e m . (HasCallStack, Member Logs e, ToLogMessage m) => m -> Eff e ()+logMsg (toLogMessage -> msgIn) =+  withFrozenCallStack $ do+    lf <- askLogPredicate+    when (lf msgIn) $+      msgIn `deepseq` send @Logs (WriteLogMessage msgIn) --- | 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 ()-  go AskLogFilter k = k (const Nothing)+-- | Log a 'String' as 'LogMessage' with a given 'Severity'.+logWithSeverity+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => Severity+  -> String+  -> Eff e ()+logWithSeverity !s =+  withFrozenCallStack+    $ logMsg+    . setCallStack callStack+    . set lmSeverity s+    . flip (set lmMessage) def --- | 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 ()-  go AskLogFilter k = k pure+-- | Log a 'String' as 'emergencySeverity'.+logEmergency+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logEmergency = withFrozenCallStack (logWithSeverity emergencySeverity) --- ** Log Message Writer Creation+-- | Log a message with 'alertSeverity'.+logAlert+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logAlert = withFrozenCallStack (logWithSeverity alertSeverity) --- | A function that takes a log message and returns an effect that--- /logs/ the message.-newtype LogWriter message writerM =-  LogWriter-  { runLogWriter-      :: forall f. (MonadPlus f, Traversable f, NFData1 f)-      => f message-      -> writerM ()-  }+-- | Log a 'criticalSeverity' message.+logCritical+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logCritical = withFrozenCallStack (logWithSeverity criticalSeverity) -instance Applicative w => Default (LogWriter m w) where-  def = LogWriter (const (pure ()))+-- | Log a 'errorSeverity' message.+logError+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logError = withFrozenCallStack (logWithSeverity errorSeverity) --- | Type alias for the 'Reader' effect that writes logs-type LogWriterReader message writerM =-  Reader (LogWriter message writerM)+-- | Log a 'warningSeverity' message.+logWarning+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logWarning = withFrozenCallStack (logWithSeverity warningSeverity) --- | Create a 'LogWriter' from a function that can write--- a 'Traversable' container.-foldingLogWriter-  :: (  forall f-      . (MonadPlus f, Traversable f, NFData1 f)-     => f message-     -> writerM ()+-- | Log a 'noticeSeverity' message.+logNotice+  :: forall e .+     ( HasCallStack+     , Member Logs e      )-  -> LogWriter message writerM-foldingLogWriter = LogWriter+  => String+  -> Eff e ()+logNotice = withFrozenCallStack (logWithSeverity noticeSeverity) --- | 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+-- | Log a 'informationalSeverity' message.+logInfo+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logInfo = withFrozenCallStack (logWithSeverity informationalSeverity) --- | 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)-  => (message -> writerM ())-  -> LogWriter message writerM-singleMessageLogWriter writeMessage = foldingLogWriter (traverse_ writeMessage)+-- | Log a 'debugSeverity' message.+logDebug+  :: forall e .+     ( HasCallStack+     , Member Logs e+     )+  => String+  -> Eff e ()+logDebug = withFrozenCallStack (logWithSeverity debugSeverity) --- | Create a 'LogWriter' from a function that is applied to each--- individual log message. Don't be scared by the type signature,--- here is an example file appender that re-opens the log file--- everytime a bunch of log messages are written:+-- $LogPredicate ----- > fileAppender fn = multiMessageLogWriter--- >   (\writeLogMessageWith ->--- >      withFile fn AppendMode (writeLogMessageWith . hPutStrLn))+-- Ways to change the 'LogPredicate' are: ---multiMessageLogWriter-  :: (Applicative writerM)-  => (((message -> writerM ()) -> writerM ()) -> writerM ())-  -> LogWriter message writerM-multiMessageLogWriter withMessageWriter =-  foldingLogWriter (\xs -> withMessageWriter (\writer -> traverse_ writer xs))---- | Get the current 'LogWriter'-askLogWriter-  :: forall m h r . (Member (Reader (LogWriter m h)) r) => Eff r (LogWriter m h)-askLogWriter = ask---- ** Low-Level Log Message Sending+--  * 'setLogPredicate'.+--  * 'modifyLogPredicate'.+--  * 'includeLogMessages'+--  * 'excludeLogMessages'+--+-- The current predicate is retrieved via 'askLogPredicate'.+--+-- Some pre-defined 'LogPredicate's can be found here: "Control.Eff.Log.Message#PredefinedPredicates" --- | A constraint that combines constraints for logging into any--- log writer monad.-type HasLogWriter message logWriterMonad effects =-  ( Member (Reader (LogWriter message logWriterMonad)) effects-  , Member (Logs message) effects-  , NFData message-  , Monad logWriterMonad-  , Lifted logWriterMonad effects-  )+-- | Get the current 'Logs' filter/transformer function.+--+-- See "Control.Eff.Log.Handler#LogPredicate"+askLogPredicate :: forall e . (Member Logs e) => Eff e LogPredicate+askLogPredicate = send @Logs AskLogFilter --- | 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-  AskLogFilter-    :: (NFData m) => Logs m (m -> Maybe m)-  LogMsgs-    :: (Traversable f, MonadPlus f, NFData1 f, NFData m, NFData (f m))-    => f m -> Logs m ()+-- | Keep only those messages, for which a predicate holds.+--+-- E.g. to keep only messages which begin with @"OMG"@:+--+-- > exampleLogPredicate :: IO Int+-- > exampleLogPredicate =+-- >     runLift+-- >   $ withLogging consoleLogWriter+-- >   $ do logMsg "test"+-- >        setLogPredicate (\ msg -> case view lmMessage msg of+-- >                                   'O':'M':'G':_ -> True+-- >                                   _             -> False)+-- >                          (do logMsg "this message will not be logged"+-- >                              logMsg "OMG logged"+-- >                              return 42)+--+-- In order to also delegate to the previous predicate, use 'modifyLogPredicate'+--+-- See "Control.Eff.Log.Handler#LogPredicate"+setLogPredicate+  :: forall r b+   . (Member Logs r, HasCallStack)+  => LogPredicate+  -> Eff r b+  -> Eff r b+setLogPredicate = modifyLogPredicate . const --- | Install 'Logs' handler that 'ask's for a 'LogWriter' for the--- message type and applies the log writer to the messages.-runLogsFiltered-  :: forall m h e b-   . (NFData m, Applicative h, Lifted h e, Member (LogWriterReader m h) e)-  => (m -> Maybe m)-  -> Eff (Logs m ': e) b+-- | Change the 'LogPredicate'.+--+-- Other than 'setLogPredicate' this function allows to include the previous predicate, too.+--+-- For to discard all messages currently no satisfying the predicate and also all messages+-- that are to long:+--+-- @+-- modifyLogPredicate (\previousPredicate msg -> previousPredicate msg && length (lmMessage msg) < 29 )+--                    (do logMsg "this message will not be logged"+--                        logMsg "this message might be logged")+-- @+--+-- See "Control.Eff.Log.Handler#LogPredicate"+modifyLogPredicate+  :: forall e b+   . (Member Logs e, HasCallStack)+  => (LogPredicate -> LogPredicate)   -> Eff e b-runLogsFiltered f = handle_relay return (go f)- where-  go :: (m -> Maybe m) -> Logs m a -> Arr e a c -> Eff e c-  go lt  AskLogFilter k = k lt-  go _lt (LogMsgs ms) k = do-    logWrtr <- ask-    lift (writeAllLogMessages logWrtr (force ms))-    k ()---- | 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, NFData m)-  => Eff (Logs m ': e) b   -> Eff e b-runLogs = runLogsFiltered pure+modifyLogPredicate lpIn e = askLogPredicate >>= fix step e . lpIn+  where+    ret x _ = return x+    step :: (Eff e b -> LogPredicate -> Eff e b) ->  Eff e b -> LogPredicate -> Eff e b+    step k (E q (prj -> Just (WriteLogMessage !l))) lp = do+      logMsg l+      respond_relay @Logs ret k (q ^$ ()) lp+    step k m lp = respond_relay @Logs ret k m lp --- | 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'.+-- | Include 'LogMessage's that match a 'LogPredicate'. ----- 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, NFData message)-  => LogWriter message writerM-  -> Eff (Logs message ': Reader (LogWriter message writerM) ': r) a-  -> Eff r a-writeLogs w = runReader w . runLogs+-- @excludeLogMessages p@ allows log message to be logged if @p m@+--+-- Although it is enough if the previous predicate holds.+-- See 'excludeLogMessages' and 'modifyLogPredicate'.+--+-- See "Control.Eff.Log.Handler#LogPredicate"+includeLogMessages+  :: forall e a . (Member Logs e)+  => LogPredicate -> Eff e a -> Eff e a+includeLogMessages p = modifyLogPredicate (\p' m -> p' m || p m) --- | 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'.+-- | Exclude 'LogMessage's that match a 'LogPredicate'. ----- Use the smart constructors below to create them, e.g.--- 'foldingLogWriter', 'singleMessageLogWriter' or--- 'mulitMessageLogWriter'.-writeLogsFiltered-  :: forall message writerM r a-   . (Applicative writerM, Lifted writerM r, NFData message)-  => (message -> Maybe message)-  -> LogWriter message writerM-  -> Eff (Logs message ': Reader (LogWriter message writerM) ': r) a-  -> Eff r a-writeLogsFiltered f w = runReader w . runLogsFiltered f+-- @excludeLogMessages p@ discards logs if @p m@+--+-- Also the previous predicate must also hold for a+-- message to be logged.+-- See 'excludeLogMessages' and 'modifyLogPredicate'.+--+-- See "Control.Eff.Log.Handler#LogPredicate"+excludeLogMessages+  :: forall e a . (Member Logs e)+  => LogPredicate -> Eff e a -> Eff e a+excludeLogMessages p = modifyLogPredicate (\p' m -> not (p m) && p' m) --- | This instance allows liftings of the 'Logs' effect, but only, if there is--- a 'LogWriter' in effect.-instance-  ( MonadBase m m-  , Lifted m r-  , NFData l-  , MonadBaseControl m (Eff r)-  )-  => MonadBaseControl m (Eff (Logs l ': LogWriterReader l m ': r)) where+-- | Consume log messages.+--+-- Exposed for custom extensions, if in doubt use 'withLogging'.+--+-- Respond to all 'LogMessage's logged from the given action,+-- up to any 'MonadBaseControl' liftings.+--+-- Note that all logging is done through 'logMsg' and that means+-- only messages passing the 'LogPredicate' are received.+--+-- The 'LogMessage's are __consumed__ once they are passed to the+-- given callback function, previous 'respondToLogMessage' invocations+-- further up in the call stack will not get the messages anymore.+--+-- Use 'interceptLogMessages' if the messages shall be passed+-- any previous handler.+--+-- NOTE: The effects of this function are __lost__ when using+-- 'MonadBaseControl', 'Catch.MonadMask', 'Catch.MonadCatch' and 'Catch.MonadThrow'.+--+-- In contrast the functions based on modifying the 'LogWriter',+-- such as 'addLogWriter' or 'censorLogs', are save to use in combination+-- with the aforementioned liftings.+respondToLogMessage+  :: forall r b+   . (Member Logs r)+  => (LogMessage -> Eff r ())+  -> Eff r b+  -> Eff r b+respondToLogMessage f e = askLogPredicate >>= fix step e+  where+    step :: (Eff r b -> LogPredicate -> Eff r b) ->  Eff r b -> LogPredicate -> Eff r b+    step k (E q (prj -> Just (WriteLogMessage !l))) lp = do+      f l+      respond_relay @Logs ret k (q ^$ ()) lp+    step k m lp = respond_relay @Logs ret k m lp+    ret x _lf = return x -    type StM (Eff (Logs l ': LogWriterReader l m ': r)) a =-      StM (Eff r) a+-- | Change the 'LogMessage's using an effectful function.+--+-- Exposed for custom extensions, if in doubt use 'withLogging'.+--+-- This differs from 'respondToLogMessage' in that the intercepted messages will be+-- written either way, albeit in altered form.+--+-- NOTE: The effects of this function are __lost__ when using+-- 'MonadBaseControl', 'Catch.MonadMask', 'Catch.MonadCatch' and 'Catch.MonadThrow'.+--+-- In contrast the functions based on modifying the 'LogWriter',+-- such as 'addLogWriter' or 'censorLogs', are save to use in combination+-- with the aforementioned liftings.+interceptLogMessages+  :: forall r b+   . (Member Logs r)+  => (LogMessage -> Eff r LogMessage)+  -> Eff r b+  -> Eff r b+interceptLogMessages f = respondToLogMessage (f >=> logMsg) -    liftBaseWith f = do-      l <- askLogWriter-      lf <- send AskLogFilter-      raise (raise (liftBaseWith (\runInBase -> f (runInBase . writeLogsFiltered lf l))))+-- | Internal function.+sendLogMessageToLogWriter+  :: forall h e b .+     (LogsTo h e, SupportsLogger h e, Member Logs e)+  => Eff e b -> Eff e b+sendLogMessageToLogWriter = respondToLogMessage messageCallback+  where+    messageCallback msg = do+      lw <- askLogWriter+      liftLogWriter lw msg -    restoreM = raise . raise . restoreM+-- | A Reader specialized for 'LogWriter's+--+-- The existing @Reader@ couldn't be used together with 'SetMember', so this+-- lazy reader was written, specialized to reading 'LogWriter'.+data LogWriterReader h v where+  AskLogWriter :: LogWriterReader h (LogWriter h) +instance Handle (LogWriterReader h) e a (LogWriter h -> k) where+  handle k q AskLogWriter lw = k (q ^$ lw) lw -instance (NFData l, Lifted m e, Catch.MonadThrow (Eff e))-  => Catch.MonadThrow (Eff (Logs l ': LogWriterReader l m ': e)) where-  throwM exception = raise (raise (Catch.throwM exception))+instance forall h m r. (MonadBase m m, LiftedBase m r)+  => MonadBaseControl m (Eff (LogWriterReader h ': r)) where+    type StM (Eff (LogWriterReader h ': r)) a =  StM (Eff r) a+    liftBaseWith f = do+      lf <- askLogWriter+      raise (liftBaseWith (\runInBase -> f (runInBase . runLogWriterReader  lf)))+    restoreM = raise . restoreM -instance (NFData l, Applicative m, Lifted m e, Catch.MonadCatch (Eff e))-  => Catch.MonadCatch (Eff (Logs l ': LogWriterReader l m ': e)) where+instance (LiftedBase m e, Catch.MonadThrow (Eff e))+  => Catch.MonadThrow (Eff (LogWriterReader h ': e)) where+  throwM exception = raise (Catch.throwM exception)++instance (Applicative m, LiftedBase m e, Catch.MonadCatch (Eff e))+  => Catch.MonadCatch (Eff (LogWriterReader h ': e)) where   catch effect handler = do-    logWriter <- ask @(LogWriter l m)-    logFilter <- send AskLogFilter-    let lower                   = writeLogsFiltered logFilter logWriter+    lf <- askLogWriter+    let lower                   = runLogWriterReader  lf         nestedEffects           = lower effect         nestedHandler exception = lower (handler exception)-    raise (raise (Catch.catch nestedEffects nestedHandler))+    raise (Catch.catch nestedEffects nestedHandler) -instance (NFData l, Applicative m, Lifted m e, Catch.MonadMask (Eff e))-  => Catch.MonadMask (Eff (Logs l ': LogWriterReader l m ': e)) where+instance (Applicative m, LiftedBase m e, Catch.MonadMask (Eff e))+  => Catch.MonadMask (Eff (LogWriterReader h ': e)) where   mask maskedEffect = do-    logWriter <- ask @(LogWriter l m)-    logFilter <- send AskLogFilter+    lf <- askLogWriter     let-      lower :: Eff (Logs l ': LogWriterReader l m ': e) a -> Eff e a-      lower = writeLogsFiltered logFilter logWriter+      lower :: Eff (LogWriterReader h ': e) a -> Eff e a+      lower = runLogWriterReader  lf     raise-      (raise         (Catch.mask           (\nestedUnmask -> lower             (maskedEffect-              ( raise . raise . nestedUnmask . lower )+              ( raise . nestedUnmask . lower )             )           )         )-      )   uninterruptibleMask maskedEffect = do-    logWriter <- ask @(LogWriter l m)-    logFilter <- send AskLogFilter+    lf <- askLogWriter     let-      lower :: Eff (Logs l ': LogWriterReader l m ': e) a -> Eff e a-      lower = writeLogsFiltered logFilter logWriter+      lower :: Eff (LogWriterReader h ': e) a -> Eff e a+      lower = runLogWriterReader  lf     raise-      (raise         (Catch.uninterruptibleMask           (\nestedUnmask -> lower             (maskedEffect-              ( raise . raise . nestedUnmask . lower )+              ( raise . nestedUnmask . lower )             )           )         )-      )-  generalBracket acquire release use = do-    logWriter <- ask @(LogWriter l m)-    logFilter <- send AskLogFilter+  generalBracket acquire release useIt = do+    lf <- askLogWriter     let-      lower :: Eff (Logs l ': LogWriterReader l m ': e) a -> Eff e a-      lower = writeLogsFiltered logFilter logWriter+      lower :: Eff (LogWriterReader h ': e) a -> Eff e a+      lower = runLogWriterReader  lf     raise-      (raise         (Catch.generalBracket           (lower acquire)           (((.).(.)) lower release)-          (lower . use)-        )+          (lower . useIt)       )++-- | Provide the 'LogWriter'+--+-- Exposed for custom extensions, if in doubt use 'withLogging'.+runLogWriterReader :: LogWriter h -> Eff (LogWriterReader h ': e) a -> Eff e a+runLogWriterReader e m = fix (handle_relay (\x _ -> return x)) m e++-- | Get the current 'LogWriter'.+askLogWriter :: SetMember LogWriterReader (LogWriterReader h) e => Eff e (LogWriter h)+askLogWriter = send AskLogWriter++-- | Change the current 'LogWriter'.+modifyLogWriter+  :: forall h e a. LogsTo h e => (LogWriter h -> LogWriter h) -> Eff e a -> Eff e a+modifyLogWriter f = localLogWriterReader . sendLogMessageToLogWriter+  where+    localLogWriterReader m =+      f <$> askLogWriter >>= fix (respond_relay @(LogWriterReader h) (\x _ -> return x)) m+++-- | Replace the current 'LogWriter'.+-- To add an additional log message consumer use 'addLogWriter'+setLogWriter :: forall h e a. LogsTo h e => LogWriter h -> Eff e a -> Eff e a+setLogWriter = modifyLogWriter  . const++-- | Modify the the 'LogMessage's written in the given sub-expression.+--+-- Note: This is equivalent to @'modifyLogWriter' . 'mappingLogWriter'@+censorLogs :: LogsTo h e => (LogMessage -> LogMessage) -> Eff e a -> Eff e a+censorLogs = modifyLogWriter . mappingLogWriter++-- | Modify the the 'LogMessage's written in the given sub-expression, as in 'censorLogs'+-- but with a effectful function.+--+-- Note: This is equivalent to @'modifyLogWriter' . 'mappingLogWriterM'@+censorLogsM+  :: (LogsTo h e, Monad h)+  => (LogMessage -> h LogMessage) -> Eff e a -> Eff e a+censorLogsM = modifyLogWriter . mappingLogWriterM++-- | Combine the effects of a given 'LogWriter' and the existing one.+--+-- > +-- > exampleAddLogWriter :: IO ()+-- > exampleAddLogWriter = go >>= putStrLn+-- >  where go = fmap (unlines . map renderLogMessage . snd)+-- >               $  runLift+-- >               $  runCapturedLogsWriter+-- >               $  withLogging listLogWriter+-- >               $  addLogWriter (mappingLogWriter (lmMessage %~ ("CAPTURED "++)) listLogWriter)+-- >               $  addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("TRACED "++)) debugTraceLogWriter))+-- >               $  do+-- >                     logEmergency "test emergencySeverity 1"+-- >                     logCritical "test criticalSeverity 2"+-- >                     logAlert "test alertSeverity 3"+-- >                     logError "test errorSeverity 4"+-- >                     logWarning "test warningSeverity 5"+-- >                     logInfo "test informationalSeverity 6"+-- >                     logDebug "test debugSeverity 7"+-- >        testPred = view (lmSeverity . to (<= errorSeverity))+-- >+--+addLogWriter :: forall h e a .+     (HasCallStack, LogsTo h e, Monad h)+  => LogWriter h -> Eff e a -> Eff e a+addLogWriter lw2 = modifyLogWriter (\lw1 -> MkLogWriter (\m -> runLogWriter lw1 m >> runLogWriter lw2 m))++-- | Open a file and add the 'LogWriter' in the 'LogWriterReader' tha appends the log messages to it.+withLogFileAppender+  :: ( Lifted IO e+     , LogsTo IO e+     , MonadBaseControl IO (Eff e)+     )+  => FilePath+  -> Eff e b+  -> Eff e b+withLogFileAppender fnIn e = liftBaseOp withOpenedLogFile (`addLogWriter` e)+  where+    withOpenedLogFile+      :: HasCallStack+      => (LogWriter IO -> IO a)+      -> IO a+    withOpenedLogFile ioE =+      Safe.bracket+          (do+            fnCanon <- canonicalizePath fnIn+            createDirectoryIfMissing True (takeDirectory fnCanon)+            h <- IO.openFile fnCanon IO.AppendMode+            IO.hSetBuffering h (IO.BlockBuffering (Just 1024))+            return h+          )+          (\h -> Safe.try @IO @Catch.SomeException (IO.hFlush h) >> IO.hClose h)+          (\h -> ioE (ioHandleLogWriter h))

src/Control/Eff/Log/Message.hs view

@@ -1,31 +1,65 @@ -- | An RFC 5434 inspired log message and convenience functions for -- logging them. module Control.Eff.Log.Message-  ( LogMessage(..)-  , HasLogging+  ( -- * Log Message Data Type+    LogMessage(..)+   -- ** Field Accessors+  , lmFacility+  , lmSeverity+  , lmTimestamp+  , lmHostname+  , lmAppName+  , lmProcessId+  , lmMessageId+  , lmStructuredData+  , lmSrcLoc+  , lmThreadId+  , lmMessage++  -- *** IO Based 'LogMessage' Modification+  , setCallStack+  , prefixLogMessagesWith+  , setLogMessageTimestamp+  , setLogMessageThreadId+  , setLogMessageHostname++  -- ** Log Message Text Rendering   , renderRFC5424   , printLogMessage-  , ioLogMessageHandler-  , ioLogMessageWriter-  , traceLogMessageWriter   , renderLogMessage-  , increaseLogMessageDistance-  , dropDistantLogMessages-  , logWithSeverity-  , logEmergency-  , logAlert-  , logCritical-  , logError-  , logWarning-  , logNotice-  , logInfo-  , logDebug++  -- ** Log Message Construction   , errorMessage   , infoMessage   , debugMessage++  -- *** Type Class for Conversion to 'LogMessage'+  , ToLogMessage(..)++  -- *** IO Based Constructor   , errorMessageIO   , infoMessageIO   , debugMessageIO++  -- * 'LogMessage' Predicates #PredefinedPredicates#+  -- $PredefinedPredicates+  , LogPredicate+  , allLogMessages+  , noLogMessages+  , lmSeverityIs+  , lmSeverityIsAtLeast+  , lmMessageStartsWith+  , discriminateByAppName++  -- ** RFC-5424 Structured Data+  , StructuredDataElement(..)+  , SdParameter(..)+  , sdName+  , sdParamValue+  , sdElementId+  , sdElementParameters++  -- * RFC 5424 Severity   , Severity(fromSeverity)   , emergencySeverity   , alertSeverity@@ -35,7 +69,10 @@   , noticeSeverity   , informationalSeverity   , debugSeverity++  -- * RFC 5424 Facility   , Facility(fromFacility)+  -- ** Facility Constructors   , kernelMessages   , userLevelMessages   , mailSystem@@ -59,152 +96,70 @@   , local5   , local6   , local7-  , lmFacility-  , lmSeverity-  , lmTimestamp-  , lmHostname-  , lmAppname-  , lmProcessId-  , lmMessageId-  , lmStructuredData-  , lmSrcLoc-  , lmThreadId-  , lmMessage-  , lmDistance-  , setCallStack-  , setLogMessageTimestamp-  , setLogMessageThreadId-  , StructuredDataElement(..)-  , sdElementId-  , sdElementParameters   ) where  import           Control.Concurrent import           Control.DeepSeq-import           Control.Eff-import           Control.Eff.Lift-import           Control.Eff.Log.Handler import           Control.Lens import           Control.Monad                  ( (>=>) ) import           Control.Monad.IO.Class import           Data.Default-import           Data.Foldable import           Data.Maybe import           Data.String import           Data.Time.Clock import           Data.Time.Format-import           Debug.Trace-import           GHC.Generics+import           GHC.Generics                   hiding (to) import           GHC.Stack+import           Network.HostName               as Network import           System.FilePath.Posix import           Text.Printf  -- | 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-             , _lmDistance :: Int }+  MkLogMessage { _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) --- | A convenient alias for the constraints that enable logging of 'LogMessage's--- in the monad, which is 'Lift'ed into a given @Eff@ effect list.-type HasLogging writerM effect = (HasLogWriter LogMessage writerM effect)--showLmMessage :: LogMessage -> [String]-showLmMessage (LogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg _dist) =-  if null msg-    then []-    else-      maybe "" (printf "[%s]" . show) ti-      : (msg ++ replicate (max 0 (60 - length msg)) ' ')-      : maybe-          []-          (\sl -> pure-            (printf "% 30s line %i"-                    (takeFileName (srcLocFile sl))-                    (srcLocStartLine sl)-            )-          )-          loc---- | A 'LogWriter' that applys 'renderLogMessage' to the log message and then--- traces it using 'traceM'.-traceLogMessageWriter :: Monad m => LogWriter LogMessage m-traceLogMessageWriter =-  foldingLogWriter (traverse_ (traceM . renderLogMessage))----- | 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 Default LogMessage where+  def = MkLogMessage def def def def def def def def def def ""  instance NFData LogMessage  -- | RFC-5424 defines how structured data can be included in a log message. data StructuredDataElement =-  SdElement { _sdElementId :: String-            , _sdElementParameters :: [SdParameter]}+  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) ++ "]"+  show (SdElement sdId params) =+    "[" ++ sdName sdId ++ if null params then "" else " " ++ unwords (show <$> params) ++ "]"  instance NFData StructuredDataElement --- | Component of a 'StructuredDataElement'+-- | Component of an RFC-5424 'StructuredDataElement' data SdParameter =-  SdParameter String String+  MkSdParameter !String !String   deriving (Eq, Ord, Generic)  instance Show SdParameter where-  show (SdParameter k v) = sdName k ++ "=\"" ++ sdParamValue v ++ "\""+  show (MkSdParameter k v) = sdName k ++ "=\"" ++ sdParamValue v ++ "\"" +-- | Extract the name of an 'SdParameter' the length is cropped to 32 according to RFC 5424. sdName :: String -> String sdName = take 32 . filter (\c -> c == '=' || c == ']' || c == ' ' || c == '"') +-- | Extract the value of an 'SdParameter'. sdParamValue :: String -> String sdParamValue e = e >>= \case   '"'  -> "\\\""@@ -228,304 +183,466 @@   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 = LogMessage def def def def def def def def def def "" 0--instance IsString LogMessage where-  fromString = infoMessage---- | Render a 'LogMessage' but set the timestamp and thread id fields.-printLogMessage :: LogMessage -> IO ()-printLogMessage = setLogMessageTimestamp >=> putStrLn . renderLogMessage---- | Set a timestamp (if not set), the thread id (if not set) using IO actions--- then /write/ the log message using the 'IO' and 'String' based 'LogWriter'.-ioLogMessageWriter-  :: HasCallStack => LogWriter String IO -> LogWriter LogMessage IO-ioLogMessageWriter delegatee = foldingLogWriter-  (   traverse setLogMessageTimestamp-  >=> traverse setLogMessageThreadId-  >=> (writeAllLogMessages delegatee . fmap renderLogMessage)-  )---- | Use 'ioLogMessageWriter' to /handle/ logging using 'handleLogs'.-ioLogMessageHandler-  :: (HasCallStack, Lifted IO e)-  => LogWriter String IO-  -> Eff (Logs LogMessage ': LogWriterReader LogMessage IO ': e) a-  -> Eff e a-ioLogMessageHandler delegatee =-  writeLogs (ioLogMessageWriter delegatee)---- | An IO action that sets the current UTC time (see 'enableLogMessageTimestamps')--- in 'lmTimestamp'.-setLogMessageTimestamp :: MonadIO m => LogMessage -> m LogMessage-setLogMessageTimestamp m = if isNothing (m ^. lmTimestamp)-  then do-    now <- liftIO getCurrentTime-    return (m & lmTimestamp ?~ now)-  else return m---- | An IO action appends the the 'ThreadId' of the calling process (see 'myThreadId')--- to 'lmMessage'.-setLogMessageThreadId :: MonadIO m => LogMessage -> m LogMessage-setLogMessageThreadId m = if isNothing (m ^. lmThreadId)-  then do-    t <- liftIO myThreadId-    return (m & lmThreadId ?~ t)-  else return m---- | Increase the /distance/ of log messages by one.--- Logs can be filtered by their distance with 'dropDistantLogMessages'-increaseLogMessageDistance-  :: (HasCallStack, HasLogWriter LogMessage h e) => Eff e a -> Eff e a-increaseLogMessageDistance = mapLogMessages (over lmDistance (+ 1))---- | Drop all log messages with an 'lmDistance' greater than the given--- value.-dropDistantLogMessages :: (HasLogging m r) => Int -> Eff r a -> Eff r a-dropDistantLogMessages maxDistance =-  filterLogMessages (\lm -> lm ^. lmDistance <= maxDistance)---- | Log a 'String' as 'LogMessage' with a given 'Severity'.-logWithSeverity-  :: ( HasCallStack-     , 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-  :: ( HasCallStack-     , Member (Logs LogMessage) e-     )-  => String-  -> Eff e ()-logEmergency = withFrozenCallStack (logWithSeverity emergencySeverity)---- | Log a message with 'alertSeverity'.-logAlert-  :: ( HasCallStack-     , Member (Logs LogMessage) e-     )-  => String-  -> Eff e ()-logAlert = withFrozenCallStack (logWithSeverity alertSeverity)---- | Log a 'criticalSeverity' message.-logCritical-  :: ( HasCallStack-     , Member (Logs LogMessage) e-     )-  => String-  -> Eff e ()-logCritical = withFrozenCallStack (logWithSeverity criticalSeverity)---- | Log a 'errorSeverity' message.-logError-  :: ( HasCallStack-     , Member (Logs LogMessage) e-     )-  => String-  -> Eff e ()-logError = withFrozenCallStack (logWithSeverity errorSeverity)---- | Log a 'warningSeverity' message.-logWarning-  :: ( HasCallStack-     , Member (Logs LogMessage) e-     )-  => String-  -> Eff e ()-logWarning = withFrozenCallStack (logWithSeverity warningSeverity)---- | Log a 'noticeSeverity' message.-logNotice-  :: ( HasCallStack-     , Member (Logs LogMessage) e-     )-  => String-  -> Eff e ()-logNotice = withFrozenCallStack (logWithSeverity noticeSeverity)---- | Log a 'informationalSeverity' message.-logInfo-  :: ( HasCallStack-     , Member (Logs LogMessage) e-     )-  => String-  -> Eff e ()-logInfo = withFrozenCallStack (logWithSeverity informationalSeverity)---- | Log a 'debugSeverity' message.-logDebug-  :: ( HasCallStack-     , Member (Logs LogMessage) e-     )-  => String-  -> Eff e ()-logDebug = withFrozenCallStack (logWithSeverity debugSeverity)---- | Construct a 'LogMessage' with 'errorSeverity'-errorMessage :: HasCallStack => String -> LogMessage-errorMessage m = withFrozenCallStack-  (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack)---- | Construct a 'LogMessage' with 'informationalSeverity'-infoMessage :: HasCallStack => String -> LogMessage-infoMessage m = withFrozenCallStack-  (  def-  &  lmSeverity-  .~ informationalSeverity-  &  lmMessage-  .~ m-  &  setCallStack callStack-  )---- | Construct a 'LogMessage' with 'debugSeverity'-debugMessage :: HasCallStack => String -> LogMessage-debugMessage m = withFrozenCallStack-  (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack)---- | Construct a 'LogMessage' with 'errorSeverity'-errorMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage-errorMessageIO =-  withFrozenCallStack-    $ (setLogMessageThreadId >=> setLogMessageTimestamp)-    . errorMessage---- | Construct a 'LogMessage' with 'informationalSeverity'-infoMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage-infoMessageIO =-  withFrozenCallStack-    $ (setLogMessageThreadId >=> setLogMessageTimestamp)-    . infoMessage---- | Construct a 'LogMessage' with 'debugSeverity'-debugMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage-debugMessageIO =-  withFrozenCallStack-    $ (setLogMessageThreadId >=> setLogMessageTimestamp)-    . debugMessage+--  *** Severities +-- | Smart constructor for the RFC-5424 __emergency__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __0__.+-- See 'lmSeverity'. emergencySeverity :: Severity emergencySeverity = Severity 0 +-- | Smart constructor for the RFC-5424 __alert__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __1__.+-- See 'lmSeverity'. alertSeverity :: Severity alertSeverity = Severity 1 +-- | Smart constructor for the RFC-5424 __critical__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __2__.+-- See 'lmSeverity'. criticalSeverity :: Severity criticalSeverity = Severity 2 +-- | Smart constructor for the RFC-5424 __error__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __3__.+-- See 'lmSeverity'. errorSeverity :: Severity errorSeverity = Severity 3 +-- | Smart constructor for the RFC-5424 __warning__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __4__.+-- See 'lmSeverity'. warningSeverity :: Severity warningSeverity = Severity 4 +-- | Smart constructor for the RFC-5424 __notice__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __5__.+-- See 'lmSeverity'. noticeSeverity :: Severity noticeSeverity = Severity 5 +-- | Smart constructor for the RFC-5424 __informational__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __6__.+-- See 'lmSeverity'. informationalSeverity :: Severity informationalSeverity = Severity 6 +-- | Smart constructor for the RFC-5424 __debug__ 'LogMessage' 'Severity'.+-- This corresponds to the severity value __7__.+-- See 'lmSeverity'. debugSeverity :: Severity debugSeverity = Severity 7  instance Default Severity where   def = debugSeverity ++-- | An rfc 5424 facility+newtype Facility = Facility {fromFacility :: Int}+  deriving (Eq, Ord, Show, Generic, NFData)++-- | Smart constructor for the RFC-5424 'LogMessage' facility @kernelMessages@.+-- See 'lmFacility'. kernelMessages :: Facility kernelMessages = Facility 0 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @userLevelMessages@.+-- See 'lmFacility'. userLevelMessages :: Facility userLevelMessages = Facility 1 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @mailSystem@.+-- See 'lmFacility'. mailSystem :: Facility mailSystem = Facility 2 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @systemDaemons@.+-- See 'lmFacility'. systemDaemons :: Facility systemDaemons = Facility 3 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages4@.+-- See 'lmFacility'. securityAuthorizationMessages4 :: Facility securityAuthorizationMessages4 = Facility 4 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @linePrinterSubsystem@.+-- See 'lmFacility'. linePrinterSubsystem :: Facility linePrinterSubsystem = Facility 6 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @networkNewsSubsystem@.+-- See 'lmFacility'. networkNewsSubsystem :: Facility networkNewsSubsystem = Facility 7 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @uucpSubsystem@.+-- See 'lmFacility'. uucpSubsystem :: Facility uucpSubsystem = Facility 8 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon@.+-- See 'lmFacility'. clockDaemon :: Facility clockDaemon = Facility 9 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @securityAuthorizationMessages10@.+-- See 'lmFacility'. securityAuthorizationMessages10 :: Facility securityAuthorizationMessages10 = Facility 10 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @ftpDaemon@.+-- See 'lmFacility'. ftpDaemon :: Facility ftpDaemon = Facility 11 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @ntpSubsystem@.+-- See 'lmFacility'. ntpSubsystem :: Facility ntpSubsystem = Facility 12 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @logAuditFacility@.+-- See 'lmFacility'. logAuditFacility :: Facility logAuditFacility = Facility 13 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @logAlertFacility@.+-- See 'lmFacility'. logAlertFacility :: Facility logAlertFacility = Facility 14 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @clockDaemon2@.+-- See 'lmFacility'. clockDaemon2 :: Facility clockDaemon2 = Facility 15 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @local0@.+-- See 'lmFacility'. local0 :: Facility local0 = Facility 16 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @local1@.+-- See 'lmFacility'. local1 :: Facility local1 = Facility 17 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @local2@.+-- See 'lmFacility'. local2 :: Facility local2 = Facility 18 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @local3@.+-- See 'lmFacility'. local3 :: Facility local3 = Facility 19 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @local4@.+-- See 'lmFacility'. local4 :: Facility local4 = Facility 20 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @local5@.+-- See 'lmFacility'. local5 :: Facility local5 = Facility 21 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @local6@.+-- See 'lmFacility'. local6 :: Facility local6 = Facility 22 +-- | Smart constructor for the RFC-5424 'LogMessage' facility @local7@.+-- See 'lmFacility'. local7 :: Facility local7 = Facility 23  instance Default Facility where   def = local7++makeLensesWith (lensRules & generateSignatures .~ False) ''StructuredDataElement++-- | A lens for 'SdParameter's+sdElementParameters :: Functor f =>+                             ([SdParameter] -> f [SdParameter])+                             -> StructuredDataElement -> f StructuredDataElement++-- | A lens for the key or ID of a group of RFC 5424 key-value pairs.+sdElementId :: Functor f =>+                     (String -> f String)+                     -> StructuredDataElement -> f StructuredDataElement++makeLensesWith (lensRules & generateSignatures .~ False) ''LogMessage++-- | A lens for the UTC time of a 'LogMessage'+-- The function 'setLogMessageTimestamp' can be used to set the field.+lmTimestamp :: Functor f =>+               (Maybe UTCTime -> f (Maybe UTCTime)) -> LogMessage -> f LogMessage++-- | A lens for the 'ThreadId' of a 'LogMessage'+-- The function 'setLogMessageThreadId' can be used to set the field.+lmThreadId :: Functor f =>+              (Maybe ThreadId -> f (Maybe ThreadId)) -> LogMessage -> f LogMessage++-- | A lens for the 'StructuredDataElement' of a 'LogMessage'+lmStructuredData :: Functor f =>+                    ([StructuredDataElement] -> f [StructuredDataElement])+                    -> LogMessage -> f LogMessage++-- | A lens for the 'SrcLoc' of a 'LogMessage'+lmSrcLoc :: Functor f =>+            (Maybe SrcLoc -> f (Maybe SrcLoc)) -> LogMessage -> f LogMessage++-- | A lens for the 'Severity' of a 'LogMessage'+lmSeverity :: Functor f =>+              (Severity -> f Severity) -> LogMessage -> f LogMessage++-- | A lens for a user defined of /process/ id of a 'LogMessage'+lmProcessId :: Functor f =>+               (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage++-- | A lens for a user defined /message id/ of a 'LogMessage'+lmMessageId :: Functor f =>+               (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage++-- | A lens for the user defined textual message of a 'LogMessage'+lmMessage :: Functor f =>+             (String -> f String) -> LogMessage -> f LogMessage++-- | A lens for the hostname of a 'LogMessage'+-- The function 'setLogMessageHostname' can be used to set the field.+lmHostname :: Functor f =>+              (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage++-- | A lens for the 'Facility' of a 'LogMessage'+lmFacility :: Functor f =>+              (Facility -> f Facility) -> LogMessage -> f LogMessage++-- | A lens for the RFC 5424 /application/ name of a 'LogMessage'+--+-- One useful pattern for using this field, is to implement log filters that allow+-- info and debug message from the application itself while only allowing warning and error+-- messages from third party libraries:+--+-- > debugLogsForAppName myAppName lm =+-- >   view lmAppName lm == Just myAppName || lmSeverityIsAtLeast warningSeverity lm+--+-- This is implemented in 'discriminateByAppName'.+lmAppName :: Functor f =>+             (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage++instance Show LogMessage where+  show = unlines . showLmMessage++-- | Print a 'LogMessage' in a very incomplete way, use only for tests and debugging+showLmMessage :: LogMessage -> [String]+showLmMessage (MkLogMessage _f _s _ts _hn _an _pid _mi _sd ti loc msg) =+  if null msg+    then []+    else+      maybe "" (printf "[%s]" . show) ti+      : (msg ++ replicate (max 0 (60 - length msg)) ' ')+      : maybe+          []+          (\sl -> pure+            (printf "% 30s line %i"+                    (takeFileName (srcLocFile sl))+                    (srcLocStartLine sl)+            )+          )+          loc+++-- | Render a 'LogMessage' human readable.+renderLogMessage :: LogMessage -> String+renderLogMessage l@(MkLogMessage _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@(MkLogMessage 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+  )++-- | Render a 'LogMessage' but set the timestamp and thread id fields.+printLogMessage :: LogMessage -> IO ()+printLogMessage = putStrLn . renderLogMessage++-- | 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++-- | Prefix the 'lmMessage'.+prefixLogMessagesWith :: String -> LogMessage -> LogMessage+prefixLogMessagesWith = over lmMessage . (<>)++-- | An IO action that sets the current UTC time in 'lmTimestamp'.+setLogMessageTimestamp :: LogMessage -> IO LogMessage+setLogMessageTimestamp m = if isNothing (m ^. lmTimestamp)+  then do+    now <- getCurrentTime+    return (m & lmTimestamp ?~ now)+  else return m++-- | An IO action appends the the 'ThreadId' of the calling process (see 'myThreadId')+-- to 'lmMessage'.+setLogMessageThreadId :: LogMessage -> IO LogMessage+setLogMessageThreadId m = if isNothing (m ^. lmThreadId)+  then do+    t <- myThreadId+    return (m & lmThreadId ?~ t)+  else return m++-- | An IO action that sets the current hosts fully qualified hostname in 'lmHostname'.+setLogMessageHostname :: LogMessage -> IO LogMessage+setLogMessageHostname m = if isNothing (m ^. lmTimestamp)+  then do+    fqdn <- Network.getHostName+    return (m & lmHostname ?~ fqdn)+  else return m++-- | Construct a 'LogMessage' with 'errorSeverity'+errorMessage :: HasCallStack => String -> LogMessage+errorMessage m = withFrozenCallStack+  (def & lmSeverity .~ errorSeverity & lmMessage .~ m & setCallStack callStack)++-- | Construct a 'LogMessage' with 'informationalSeverity'+infoMessage :: HasCallStack => String -> LogMessage+infoMessage m = withFrozenCallStack+  (  def+  &  lmSeverity+  .~ informationalSeverity+  &  lmMessage+  .~ m+  &  setCallStack callStack+  )++-- | Construct a 'LogMessage' with 'debugSeverity'+debugMessage :: HasCallStack => String -> LogMessage+debugMessage m = withFrozenCallStack+  (def & lmSeverity .~ debugSeverity & lmMessage .~ m & setCallStack callStack)++-- | Construct a 'LogMessage' with 'errorSeverity'+errorMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage+errorMessageIO =+  withFrozenCallStack+    $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)+    . errorMessage++-- | Construct a 'LogMessage' with 'informationalSeverity'+infoMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage+infoMessageIO =+  withFrozenCallStack+    $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)+    . infoMessage++-- | Construct a 'LogMessage' with 'debugSeverity'+debugMessageIO :: (HasCallStack, MonadIO m) => String -> m LogMessage+debugMessageIO =+  withFrozenCallStack+    $ (liftIO . setLogMessageThreadId >=> liftIO . setLogMessageTimestamp)+    . debugMessage++-- | Things that can become a 'LogMessage'+class ToLogMessage a where+  -- | Convert the value to a 'LogMessage'+  toLogMessage :: a -> LogMessage++instance ToLogMessage LogMessage where+  toLogMessage = id++instance ToLogMessage String where+  toLogMessage = infoMessage++instance IsString LogMessage where+  fromString = infoMessage++-- $PredefinedPredicates+-- == Log Message Predicates+--+-- These are the predefined 'LogPredicate's:+--+--  * 'allLogMessages'+--  * 'noLogMessages'+--  * 'lmSeverityIsAtLeast'+--  * 'lmSeverityIs'+--  * 'lmMessageStartsWith'+--  * 'discriminateByAppName'+--+-- To find out how to use these predicates,+-- goto "Control.Eff.Log.Handler#LogPredicate"+++-- | The filter predicate for message that shall be logged.+--+-- See "Control.Eff.Log.Handler#LogPredicate"+type LogPredicate = LogMessage -> Bool++-- | All messages.+allLogMessages :: LogPredicate+allLogMessages = const True++-- | No messages.+noLogMessages :: LogPredicate+noLogMessages = const False++-- | Match 'LogMessage's that have exactly the given severity.+-- See 'lmSeverityIsAtLeast'.+--+-- See "Control.Eff.Log.Handler#LogPredicate"+lmSeverityIs :: Severity -> LogPredicate+lmSeverityIs s = view (lmSeverity . to (== s))++-- | Match 'LogMessage's that have the given severity __or worse__.+-- See 'lmSeverityIs'.+--+-- See "Control.Eff.Log.Handler#LogPredicate"+lmSeverityIsAtLeast :: Severity -> LogPredicate+lmSeverityIsAtLeast s = view (lmSeverity . to (<= s))++-- | Match 'LogMessage's whose 'lmMessage' starts with the given string.+--+-- See "Control.Eff.Log.Handler#LogPredicate"+lmMessageStartsWith :: String -> LogPredicate+lmMessageStartsWith prefix lm =+  case length prefix of+    0         -> True+    prefixLen -> take prefixLen (lm ^. lmMessage) == prefix++-- | Apply discriminate 'LogMessage's by their 'lmAppName' and delegate+-- to one of two 'LogPredicate's.+--+-- One useful application for this is to allow info and debug message+-- from one application, e.g. the current application itself,+-- while at the same time allowing only warning and error messages+-- from third party libraries.+discriminateByAppName :: String -> LogPredicate -> LogPredicate -> LogPredicate+discriminateByAppName appName appPredicate otherPredicate lm =+   if view lmAppName lm == Just appName+      then appPredicate lm+      else otherPredicate lm

+ src/Control/Eff/Log/Writer.hs view

@@ -0,0 +1,169 @@+{-# LANGUAGE UndecidableInstances #-}+-- | The 'LogWriter' type encapsulates an effectful function to write 'LogMessage's.+--+-- Used in conjunction with the 'SupportsLogger' class, it+-- can be used to write messages from within an effectful+-- computation.+module Control.Eff.Log.Writer+  ( -- * 'LogWriter' Definition+    LogWriter(MkLogWriter, runLogWriter)+  , SupportsLogger(..)+  -- ** 'LogWriter' Zoo+  -- *** Pure Writer+  , noOpLogWriter+  , debugTraceLogWriter+  , PureLogWriter(..)+  , listLogWriter+  , CaptureLogs(..)+  , CapturedLogsWriter+  , runCapturedLogsWriter+  -- ** IO Based 'LogWriter'+  , consoleLogWriter+  , ioHandleLogWriter+  -- *** General Combinator+  , filteringLogWriter+  , mappingLogWriter+  , mappingLogWriterM+  -- *** IO Based Combinator+  , ioLogWriter+  , defaultIoLogWriter+  ) where++import Control.Eff+import Control.Eff.Log.Message+import Data.Default+import Debug.Trace+import GHC.Stack+import Control.Eff.Writer.Strict (Writer, tell, runListWriter)+import Data.Functor.Identity (Identity)+import Control.DeepSeq (deepseq)+import Data.Foldable (traverse_)+import System.IO+import Control.Monad ((>=>))+import Control.Lens++-- | A function that takes a log message and returns an effect that+-- /logs/ the message.+newtype LogWriter writerM = MkLogWriter+  { runLogWriter :: LogMessage -> writerM ()+  }++instance Applicative w => Default (LogWriter w) where+  def = MkLogWriter (const (pure ()))++-- * LogWriter liftings++-- | This class describes how to lift the log writer action into some monad.+--+-- The second parameter is almost always @Eff x@+-- so usually the method of this class lifts the log writer action into an effect monad.+class SupportsLogger h e where+  liftLogWriter :: LogWriter h -> LogMessage -> Eff e ()++-- * 'LogWriter' Zoo++-- ** Pure Log Writers++-- | A base monad for all side effect free 'LogWriter'.+--+-- This is only required e.g. when logs are only either discarded or traced.+-- See 'debugTraceLogWriter' or 'noOpLogWriter'.+--+-- This is just a wrapper around 'Identity' and serves as a type that has a special+-- 'SupportsLogger' instance.+newtype PureLogWriter a = MkPureLogWriter { runPureLogWriter :: Identity a }+  deriving (Functor, Applicative, Monad)++-- | A 'LogWriter' monad for 'Debug.Trace' based pure logging.+instance SupportsLogger PureLogWriter e where+  liftLogWriter lw msg = deepseq (runPureLogWriter (runLogWriter lw msg)) (return ())++-- | This 'LogWriter' will discard all messages.+--+-- NOTE: This is just an alias for 'def'+noOpLogWriter :: Applicative m => LogWriter m+noOpLogWriter = def++-- | A 'LogWriter' that applies 'renderLogMessage' to the log message and then+-- traces it using 'traceM'.+-- This 'LogWriter' work with /any/ base monad.+debugTraceLogWriter :: Monad h => LogWriter h+debugTraceLogWriter = MkLogWriter (traceM . renderLogMessage)++-- ** Impure logging++-- | A 'LogWriter' monad that provides pure logging by capturing via the 'Writer' effect.+listLogWriter :: LogWriter CaptureLogs+listLogWriter = MkLogWriter (MkCaptureLogs . tell)++-- | A 'LogWriter' monad that provides pure logging by capturing via the 'Writer' effect.+newtype CaptureLogs a = MkCaptureLogs { unCaptureLogs :: Eff '[CapturedLogsWriter] a }+  deriving (Functor, Applicative, Monad)++-- | A 'LogWriter' monad for pure logging.+--+-- The 'SupportsLogger' instance for this type assumes a 'Writer' effect.+instance Member CapturedLogsWriter e => SupportsLogger CaptureLogs e where+  liftLogWriter lw = traverse_ (tell @LogMessage) . snd . run . runListWriter . unCaptureLogs . runLogWriter lw++-- | Run a 'Writer' for 'LogMessage's.+--+-- Such a 'Writer' is needed for 'CaptureLogs'+runCapturedLogsWriter :: Eff (CapturedLogsWriter ': e) a -> Eff e (a, [LogMessage])+runCapturedLogsWriter = runListWriter++-- | Alias for the 'Writer' that contains the captured 'LogMessage's from 'CaptureLogs'.+type CapturedLogsWriter = Writer LogMessage++-- | A 'LogWriter' that uses an 'IO' action to write the message.+--+-- Example use cases for this function are the 'consoleLogWriter' and the 'ioHandleLogWriter'.+ioLogWriter :: HasCallStack => (LogMessage-> IO ()) -> LogWriter IO+ioLogWriter = MkLogWriter++-- | A 'LogWriter' that uses an 'IO' action to write the message.+ioHandleLogWriter :: HasCallStack => Handle -> LogWriter IO+ioHandleLogWriter h = ioLogWriter (hPutStrLn h . renderLogMessage)++instance (Lifted IO e) => SupportsLogger IO e where+  liftLogWriter = (lift . ) . runLogWriter++-- | Write 'LogMessage's to standard output, formatted with 'printLogMessage'.+consoleLogWriter :: LogWriter IO+consoleLogWriter = ioLogWriter printLogMessage++-- | Decorate an IO based 'LogWriter' to set important fields in log messages.+--+-- ALl log messages are censored to include basic log message information:+--+-- * The messages will carry the given application name in the 'lmAppName' field.+-- * The 'lmTimestamp' field contains the UTC time of the log event+-- * The 'lmThreadId' field contains the thread-Id+-- * The 'lmHostname' field contains the FQDN of the current host+-- * The 'lmFacility' field contains the given 'Facility'+--+-- It installs the given 'LogWriter', wrapped using 'mappingLogWriterM'.+defaultIoLogWriter :: String -> Facility -> LogWriter IO -> LogWriter IO+defaultIoLogWriter appName facility =+  mappingLogWriterM+    (   setLogMessageThreadId+    >=> setLogMessageTimestamp+    >=> setLogMessageHostname+    >=> pure+         . set lmFacility facility+         . set lmAppName (Just appName)+    )++-- | A 'LogWriter' that applies a predicate to the 'LogMessage' and delegates to+-- to the given writer of the predicate is satisfied.+filteringLogWriter :: Monad e => LogPredicate -> LogWriter e -> LogWriter e+filteringLogWriter p lw = MkLogWriter (\msg -> if p msg then (runLogWriter lw msg) else return ())++-- | A 'LogWriter' that applies a function to the 'LogMessage' and delegates the result to+-- to the given writer.+mappingLogWriter :: (LogMessage -> LogMessage) -> LogWriter e -> LogWriter e+mappingLogWriter f lw = MkLogWriter (runLogWriter lw . f)++-- | Like 'mappingLogWriter' allow the function that changes the 'LogMessage' to have effects.+mappingLogWriterM :: Monad e => (LogMessage -> e LogMessage) -> LogWriter e -> LogWriter e+mappingLogWriterM f lw = MkLogWriter (f >=> runLogWriter lw)

− stack.nightly-2018-05-29.yaml

@@ -1,68 +0,0 @@-# This file was automatically generated by 'stack init'-#-# Some commonly used options have been documented as comments in this file.-# For advanced use and comprehensive documentation of the format, please see:-# https://docs.haskellstack.org/en/stable/yaml_configuration/--# Resolver to choose a 'specific' stackage snapshot or a compiler version.-# A snapshot resolver dictates the compiler version and the set of packages-# to be used for project dependencies. For example:-#-# resolver: lts-3.5-# resolver: nightly-2015-09-21-# resolver: ghc-7.10.2-# resolver: ghcjs-0.1.0_ghc-7.10.2-# resolver:-#  name: custom-snapshot-#  location: "./custom-snapshot.yaml"-resolver: nightly-2018-05-29--# User packages to be built.-# Various formats can be used as shown in the example below.-#-# packages:-# - some-directory-# - https://example.com/foo/bar/baz-0.0.2.tar.gz-# - location:-#    git: https://github.com/commercialhaskell/stack.git-#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a-# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a-#   extra-dep: true-#  subdirs:-#  - auto-update-#  - wai-#-# A package marked 'extra-dep: true' will only be built if demanded by a-# non-dependency (i.e. a user package), and its test suites and benchmarks-# will not be run. This is useful for tweaking upstream packages.-packages:-- .-# Dependency packages to be pulled from upstream that are not in the resolver-# (e.g., acme-missiles-0.3)-extra-deps:-- brittany-0.10.0.0-- extensible-effects-3.0.0.0--# Override default flag values for local packages and extra-deps-# flags: {}--# Extra package databases containing global packages-# extra-package-dbs: []--# Control whether we use the GHC we find on the path-# system-ghc: true-#-# Require a specific version of stack, using version ranges-# require-stack-version: -any # Default-require-stack-version: ">=1.6"-#-# Override the architecture used by stack, especially useful on Windows-# arch: i386-# arch: x86_64-#-# Extra directories used by stack for building-# extra-include-dirs: [/path/to/dir]-# extra-lib-dirs: [/path/to/dir]-#-# Allow a newer minor version of GHC than the snapshot specifies-# compiler-check: newer-minor

stack.yaml view

@@ -15,7 +15,7 @@ # resolver: #  name: custom-snapshot #  location: "./custom-snapshot.yaml"-resolver: lts-12.19+resolver: lts-13.13  # User packages to be built. # Various formats can be used as shown in the example below.@@ -40,7 +40,7 @@   # Dependency packages to be pulled from upstream that are not in the resolver   # (e.g., acme-missiles-0.3) extra-deps:-  - extensible-effects-3.1.0.2+  - extensible-effects-5.0.0.1   # Override default flag values for local packages and extra-deps   # flags: {}   # Extra package databases containing global packages

test/Common.hs view

@@ -1,76 +1,50 @@ module Common where -import           Control.Concurrent-import           Control.Concurrent.STM-import           Control.Eff.Concurrent.Process-import           Control.Eff-import           Control.Eff.Extend-import           Control.Eff.Log-import           Control.Eff.Lift-import           Control.Lens-import           Control.Monad                  ( void-                                                , when-                                                )-import           Test.Tasty-import           Test.Tasty.HUnit-import           Test.Tasty.Runners-import           GHC.Stack+import Control.Concurrent+import Control.Concurrent.STM+import Control.Eff+import Control.Eff.Concurrent.Process+import Control.Eff.Extend+import Control.Eff.Log+import Control.Monad (void)+import GHC.Stack+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Runners  setTravisTestOptions :: TestTree -> TestTree-setTravisTestOptions =-  localOption (timeoutSeconds 60) . localOption (NumThreads 1)+setTravisTestOptions = localOption (timeoutSeconds 60) . localOption (NumThreads 1)  timeoutSeconds :: Integer -> Timeout timeoutSeconds seconds = Timeout (seconds * 1000000) (show seconds ++ "s") -withTestLogC-  :: (e -> LogChannel LogMessage -> IO ())-  -> (IO (e -> IO ()) -> TestTree)-  -> TestTree-withTestLogC doSchedule k = k-  (return-    (\e -> withAsyncLogChannel-      (1000 :: Integer)-      (multiMessageLogWriter-        (\writeWith ->-          writeWith-            (\m -> when (view lmSeverity m < errorSeverity) $ printLogMessage m)-        )-      )-      (doSchedule e)-    )-  )+withTestLogC :: (e -> IO ()) -> (IO (e -> IO ()) -> TestTree) -> TestTree+withTestLogC doSchedule k = k (return doSchedule)  untilInterrupted :: Member t r => t (ResumeProcess v) -> Eff r () untilInterrupted pa = do   r <- send pa   case r of     Interrupted _ -> return ()-    _             -> untilInterrupted pa+    _ -> untilInterrupted pa -scheduleAndAssert-  :: forall r-   . (SetMember Lift (Lift IO) r, Member (Logs LogMessage) r)+scheduleAndAssert ::+     forall r. (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())-  -> (  (String -> Bool -> Eff (InterruptableProcess r) ())-     -> Eff (InterruptableProcess r) ()-     )+  -> ((String -> Bool -> Eff (InterruptableProcess r) ()) -> Eff (InterruptableProcess r) ())   -> IO ()-scheduleAndAssert schedulerFactory testCaseAction = withFrozenCallStack $ do-  resultVar <- newEmptyTMVarIO-  void-    (applySchedulerFactory-      schedulerFactory-      (testCaseAction-        (\title cond -> lift (atomically (putTMVar resultVar (title, cond))))-      )-    )-  (title, result) <- atomically (takeTMVar resultVar)-  assertBool title result+scheduleAndAssert schedulerFactory testCaseAction =+  withFrozenCallStack $ do+    resultVar <- newEmptyTMVarIO+    void+      (applySchedulerFactory+         schedulerFactory+         (testCaseAction (\title cond -> lift (atomically (putTMVar resultVar (title, cond))))))+    (title, result) <- atomically (takeTMVar resultVar)+    assertBool title result -applySchedulerFactory-  :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+applySchedulerFactory ::+     forall r. (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> Eff (InterruptableProcess r) ()   -> IO ()

test/ForkIOScheduler.hs view

@@ -5,8 +5,6 @@ import           Control.Concurrent.Async import           Control.Concurrent.STM import           Control.Eff.Extend-import           Control.Eff.Lift-import           Control.Eff.Log import           Control.Eff.Loop import           Control.Eff.Concurrent.Process import           Control.Eff.Concurrent.Process.Timer@@ -19,8 +17,6 @@ import           Test.Tasty.HUnit import           Data.Dynamic import           Common-import           Numeric.Natural-import           Data.Default  test_IOExceptionsIsolated :: TestTree test_IOExceptionsIsolated = setTravisTestOptions $ testGroup@@ -33,10 +29,7 @@         )       $ do           aVar <- newEmptyTMVarIO-          withAsyncLogChannel-            (1000 :: Natural)-            def -- (singleMessageLogWriter (putStrLn . renderLogMessage))-            (Scheduler.defaultMainWithLogChannel+          (Scheduler.defaultMain               (do                 p1 <- spawn $ foreverCheap busyEffect                 lift (threadDelay 1000)@@ -94,29 +87,21 @@ test_mainProcessSpawnsAChildAndReturns = setTravisTestOptions   (testCase     "spawn a child and return"-    (withAsyncLogChannel-      (1000 :: Natural)-      def-      (Scheduler.defaultMainWithLogChannel+      (Scheduler.defaultMain         (void (spawn (void receiveAnyMessage)))       )-    )   )  test_mainProcessSpawnsAChildAndExitsNormally :: TestTree test_mainProcessSpawnsAChildAndExitsNormally = setTravisTestOptions   (testCase     "spawn a child and exit normally"-    (withAsyncLogChannel-      (1000 :: Natural)-      def-      (Scheduler.defaultMainWithLogChannel+      (Scheduler.defaultMain         (do           void (spawn (void receiveAnyMessage))           void exitNormally           fail "This should not happen!!"         )-      )     )   ) @@ -126,10 +111,7 @@   setTravisTestOptions     (testCase       "spawn a child with a busy send loop and exit normally"-      (withAsyncLogChannel-        (1000 :: Natural)-        def-        (Scheduler.defaultMainWithLogChannel+        (Scheduler.defaultMain           (do             void (spawn (foreverCheap (void (sendMessage 1000 "test"))))             void exitNormally@@ -137,55 +119,44 @@           )         )       )-    )   test_mainProcessSpawnsAChildBothReturn :: TestTree test_mainProcessSpawnsAChildBothReturn = setTravisTestOptions   (testCase     "spawn a child and let it return and return"-    (withAsyncLogChannel-      (1000 :: Natural)-      def-      (Scheduler.defaultMainWithLogChannel+    (Scheduler.defaultMain         (do           child <- spawn (void (receiveMessage @String))           sendMessage child "test"           return ()         )-      )-    )-  )+  ))  test_mainProcessSpawnsAChildBothExitNormally :: TestTree test_mainProcessSpawnsAChildBothExitNormally = setTravisTestOptions   (testCase     "spawn a child and let it exit and exit"-    (withAsyncLogChannel-      (1000 :: Natural)-      def-      (Scheduler.defaultMainWithLogChannel-        (do-          child <- spawn $ void $ provideInterrupts $ exitOnInterrupt-            (do-              void (receiveMessage @String)+      (Scheduler.defaultMain+           (do+              child <- spawn $ void $ provideInterrupts $ exitOnInterrupt+                (do+                  void (receiveMessage @String)+                  void exitNormally+                  error "This should not happen (child)!!"+                )+              sendMessage child "test"               void exitNormally-              error "This should not happen (child)!!"+              error "This should not happen!!"             )-          sendMessage child "test"-          void exitNormally-          error "This should not happen!!"-        )       )     )-  )  test_timer :: TestTree test_timer =   setTravisTestOptions     $ testCase "flush via timer"-    $ withAsyncLogChannel (1000 :: Natural) def-    $ Scheduler.defaultMainWithLogChannel+    $ Scheduler.defaultMain     $ do         let n = 100             testMsg :: Float

test/Interactive.hs view

@@ -2,7 +2,6 @@  import           Control.Concurrent import           Control.Eff-import           Control.Eff.Lift import           Control.Eff.Concurrent.Process import           Control.Eff.Concurrent.Process.Interactive import qualified Control.Eff.Concurrent.Process.SingleThreadedScheduler

test/LoggingTests.hs view

@@ -1,40 +1,45 @@ module LoggingTests where  import           Control.Eff-import           Control.Eff.Lift import           Control.Eff.Log import           Test.Tasty import           Test.Tasty.HUnit import           Common-import           Control.Concurrent.STM-import           Control.DeepSeq+import           Control.Lens       ((.~)) -demo :: ([Logs String, Logs OtherLogMsg] <:: e) => Eff e ()-demo = do-  logMsg "jo"-  logMsg (OtherLogMsg "test 123") +test_Logging :: TestTree+test_Logging = setTravisTestOptions $ testGroup "Logging"+  [ basics+  , strictness+  ] -test_loggingInterception :: TestTree-test_loggingInterception = setTravisTestOptions $ testGroup-  "Intercept Logging"-  [ testCase "Convert Log Message Type" $ do-      otherLogsQueue  <- newTQueueIO @OtherLogMsg-      stringLogsQueue <- newTQueueIO @String-      runLift-        (writeLogs-          (multiMessageLogWriter ($ (atomically . writeTQueue stringLogsQueue)))-          (writeLogs-            (multiMessageLogWriter ($ (atomically . writeTQueue otherLogsQueue))-            )-            (mapLogMessages @String reverse  demo)-          )-        ) -      otherLogs <- atomically (flushTQueue otherLogsQueue)-      strLogs   <- atomically (flushTQueue stringLogsQueue)-      assertEqual "string logs" ["oj"]                   strLogs-      assertEqual "other logs"  [OtherLogMsg "test 123"] otherLogs-  ]+basics :: HasCallStack => TestTree+basics =+  testCase "basic logging works" $+      pureLogs demo @?= (lmSrcLoc .~ Nothing) <$> [infoMessage "jo", debugMessage "oh"]+ where -newtype OtherLogMsg = OtherLogMsg String deriving (Eq, NFData, Show)+    demo :: ('[Logs] <:: e) => Eff e ()+    demo = do+      logInfo "jo"+      logDebug "oh"++    pureLogs :: Eff '[Logs, LogWriterReader CaptureLogs, CapturedLogsWriter] a -> [LogMessage]+    pureLogs =+        snd+      . run+      . runCapturedLogsWriter+      . withLogging listLogWriter+      . censorLogs @CaptureLogs (lmSrcLoc .~ Nothing)++strictness :: HasCallStack => TestTree+strictness =+  testCase "messages failing the predicate are not deeply evaluated"+    $ runLift+    $ withLogging consoleLogWriter+    $ excludeLogMessages (lmSeverityIs errorSeverity)+    $ do logDebug "test"+         logMsg (errorMessage ("test" ++ error "TEST FAILED: this log statement should not have been evaluated deeply"))+

test/LoopTests.hs view

@@ -25,10 +25,7 @@                     "scheduleMonadIOEff with many yields from replicateCheapM_"                 $ do                       res <--                          Scheduler.scheduleIOWithLogging-                                  (multiMessageLogWriter-                                      ($! (putStrLn . (">>> " ++)))-                                  )+                          Scheduler.scheduleIOWithLogging  consoleLogWriter                               $ replicateCheapM_ soMany yieldProcess                       res @=? Right ()             , testCase@@ -46,12 +43,7 @@             , testCase                     "'foreverCheap' inside a child process and 'replicateCheapM_' in the main process"                 $ do-                      res <--                          Scheduler.scheduleIOWithLogging-                                  (multiMessageLogWriter-                                      ($! (putStrLn . (">>> " ++)))-                                  )-+                      res <- Scheduler.scheduleIOWithLogging  (ioLogWriter (putStrLn . (">>> " ++) . renderLogMessage))                               $ do                                     me <- self                                     spawn_ (foreverCheap $ sendMessage me ())@@ -72,10 +64,7 @@             [ testCase "scheduleMonadIOEff with many yields from replicateM_"                 $ do                       res <--                          Scheduler.scheduleIOWithLogging-                                  (multiMessageLogWriter-                                      ($! (putStrLn . (">>> " ++)))-                                  )+                          Scheduler.scheduleIOWithLogging  (ioLogWriter (putStrLn . (">>> " ++) . renderLogMessage))                               $ replicateM_ soMany yieldProcess                       res @=? Right ()             , testCase@@ -95,10 +84,7 @@                     "'forever' inside a child process and 'replicateM_' in the main process"                 $ do                       res <--                          Scheduler.scheduleIOWithLogging-                                  (multiMessageLogWriter-                                      ($! (putStrLn . (">>> " ++)))-                                  )+                          Scheduler.scheduleIOWithLogging  (ioLogWriter (putStrLn . (">>> " ++) . renderLogMessage))                               $ do                                     me <- self                                     spawn_ (forever $ sendMessage me ())

test/ProcessBehaviourTestCases.hs view

@@ -20,38 +20,44 @@ import           Control.Eff.Extend import           Control.Eff.Log import           Control.Eff.Loop-import           Control.Eff.Lift import           Control.Monad import           Test.Tasty import           Test.Tasty.HUnit import           Common import           Control.Applicative import           Data.Void+import Control.Lens (view)  testInterruptReason :: InterruptReason testInterruptReason = ProcessError "test interrupt"  test_forkIo :: TestTree test_forkIo = setTravisTestOptions $ withTestLogC-  (\c lc -> handleLoggingAndIO_ (ForkIO.schedule c) lc)+  (\c ->+      runLift+    $ withSomeLogging @IO+    $ withAsyncLogging (100 :: Int) (ioLogWriter (\m -> when (view lmSeverity m < errorSeverity) (printLogMessage m)))+    $ ForkIO.schedule c)   (\factory -> testGroup "ForkIOScheduler" [allTests factory])   test_singleThreaded :: TestTree test_singleThreaded = setTravisTestOptions $ withTestLogC-  (\e logC ->-        -- void (runLift (logToChannel logC (SingleThreaded.schedule (return ()) e)))+  (\e ->     let runEff-          :: Eff '[Logs LogMessage, LogWriterReader LogMessage IO, Lift IO] a+          :: Eff LoggingAndIo a           -> IO a-        runEff = flip handleLoggingAndIO logC+        runEff =+            runLift+          . withLogging+              (ioLogWriter (\m -> when (view lmSeverity m < errorSeverity) (printLogMessage m)))     in  void $ SingleThreaded.scheduleM runEff yield e   )   (\factory -> testGroup "SingleThreadedScheduler" [allTests factory])  allTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree allTests schedulerFactory = localOption@@ -102,23 +108,25 @@ stopReturnToSender toP = call toP StopReturnToSender  returnToSenderServer-  :: forall q . ( HasCallStack, Member (Logs LogMessage) q )+  :: forall q+   . (HasCallStack, Member Logs q)   => Eff (InterruptableProcess q) (Server ReturnToSender) returnToSenderServer = spawnApiServer-  (handleCalls (\m k -> k $-                        case m of-                          StopReturnToSender -> do-                            return (Nothing, StopServer testInterruptReason)-                          ReturnToSender fromP echoMsg -> do-                            sendMessage fromP echoMsg-                            yieldProcess-                            return (Just True, AwaitNext)-                        )-  ) stopServerOnInterrupt+  (handleCalls+    (\m k -> k $ case m of+      StopReturnToSender -> do+        return (Nothing, StopServer testInterruptReason)+      ReturnToSender fromP echoMsg -> do+        sendMessage fromP echoMsg+        yieldProcess+        return (Just True, AwaitNext)+    )+  )+  stopServerOnInterrupt  selectiveReceiveTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree selectiveReceiveTests schedulerFactory = setTravisTestOptions@@ -137,8 +145,8 @@               void $ receiveSelectedMessage (filterMessage (== n))               go (n - 1) -          senderLoop receviverPid =-            traverse_ (sendMessage receviverPid) [1 .. nMax]+          senderLoop destination =+            traverse_ (sendMessage destination) [1 .. nMax]          me          <- self         receiverPid <- spawn (receiverLoop me)@@ -163,15 +171,15 @@       ()   <- receiveMessage       ()   <- receiveMessage       -- replicateCheapM_ 40 yieldProcess-      msgs <- flushMessages-      lift (length msgs @?= 30)+      messages <- flushMessages+      lift (length messages @?= 30)     ]   )   yieldLoopTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree yieldLoopTests schedulerFactory =@@ -211,7 +219,7 @@  pingPongTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree pingPongTests schedulerFactory = testGroup@@ -286,7 +294,7 @@  errorTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree errorTests schedulerFactory = testGroup@@ -331,7 +339,7 @@  concurrencyTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree concurrencyTests schedulerFactory =@@ -442,7 +450,7 @@  exitTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree exitTests schedulerFactory =@@ -591,7 +599,7 @@  sendShutdownTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree sendShutdownTests schedulerFactory = testGroup@@ -684,7 +692,7 @@  linkingTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree linkingTests schedulerFactory = setTravisTestOptions@@ -851,7 +859,7 @@  monitoringTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree monitoringTests schedulerFactory = setTravisTestOptions@@ -921,7 +929,7 @@  timerTests   :: forall r-   . (Member (Logs LogMessage) r, SetMember Lift (Lift IO) r)+   . (Lifted IO r, LogsTo IO r)   => IO (Eff (InterruptableProcess r) () -> IO ())   -> TestTree timerTests schedulerFactory = setTravisTestOptions

+ with-hoogle.nix view

@@ -0,0 +1,22 @@+# Use `ghc.WithHoogle` as `ghc` in `haskellPackages`+{++# Library of functions to use, for composeExtensions.+lib ? (import <nixpkgs> {}).pkgs.lib++# Input set of all haskell packages. A valid input would be:+# (import <nixpkgs> {}).pkgs.haskellPackages+haskellPackages ? (import <nixpkgs> {}).pkgs.haskellPackages++}:++haskellPackages.override+  (old: {+    overrides =+      lib.composeExtensions+      (old.overrides or (_: _: {}))+      (self: super: {+        ghc = super.ghc // { withPackages = super.ghc.withHoogle; };+        ghcWithPackages = self.ghc.withPackages;+      });+  })