diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -20,7 +20,7 @@ script: - stack --no-terminal --skip-ghc-check build - - stack --no-terminal --skip-ghc-check build --test --test-arguments '-p "$0 !~ /Loops WITH space leaks/ " --num-threads=2 +RTS -qa -qm -N2 -maxN2 -RTS' + - stack --no-terminal --skip-ghc-check build --test --test-arguments '-p "$0 !~ /Loops WITH space leaks/ " --num-threads=2' - stack --no-terminal --skip-ghc-check haddock cache: diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,20 @@ # Changelog for extensible-effects-concurrent +## 0.19.1 + +- Fix Travis build +- Fix typos +- Fix README + +## 0.19.0 + +- Adapt to extensible-effects-concurrent 5.0.0.1 +- Update to Stackage LTS-13.13 +- Improve NIX expressions +- Rewrite the logging API +- Improve Documentation +- Add Examples + ## 0.18.1 - Fix inappropriate `LinkedProcessCrashed` interrupt when a process exits with `NotRecovered ProcessFinished` @@ -104,7 +119,7 @@ - Fix a bug in the logging system that caused all log filters to be forgotten when using unliftings such as `MonadBaseControl`, `MonadThrow`, `MonadCatch` and `MonadMask` -- Fix the scheduler schutdown to not always run into the cancellation timeout +- Fix the scheduler shutdown to not always run into the cancellation timeout ## 0.11.1 @@ -155,7 +170,7 @@ - Make all `ApiHandler` handler callbacks optional (by changing the type to `Maybe ...`) - `ApiHandler` must now return an `ApiServerCmd`. - Add `ApiServerCmd` which allows handler functions to leave to server loop without - exitting the process + exiting the process - Fix `Observer.Queue` - Rename fields in `ApiHandler` - Add smart constructors for `ApiHandler` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -28,24 +28,20 @@ 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 = defaultMain firstExample -newtype WhoAreYou = WhoAreYou ProcessId deriving (Typeable, NFData, Show) +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 @@ -59,27 +55,25 @@ personName <- receiveMessage logInfo ("I just met " ++ personName) - ``` **Running** this example causes this output: -(_not entirely true because of async logging, but true enough_) ```text -2018-11-05T10:50:42 DEBUG scheduler loop entered ForkIOScheduler.hs line 131 -2018-11-05T10:50:42 DEBUG !1 [ThreadId 11] enter process ForkIOScheduler.hs line 437 -2018-11-05T10:50:42 NOTICE !1 [ThreadId 11] ++++++++ main process started ++++++++ ForkIOScheduler.hs line 394 -2018-11-05T10:50:42 DEBUG !2 [ThreadId 12] enter process ForkIOScheduler.hs line 437 -2018-11-05T10:50:42 INFO !2 [ThreadId 12] I am waiting for someone to ask me... Main.hs line 27 -2018-11-05T10:50:42 INFO !2 [ThreadId 12] !1 just needed to know it. Main.hs line 30 -2018-11-05T10:50:42 DEBUG !2 [ThreadId 12] returned ForkIOScheduler.hs line 440 -2018-11-05T10:50:42 INFO !1 [ThreadId 11] I just met Alice Main.hs line 35 -2018-11-05T10:50:42 NOTICE !1 [ThreadId 11] ++++++++ main process returned ++++++++ ForkIOScheduler.hs line 396 -2018-11-05T10:50:42 DEBUG !1 [ThreadId 11] returned ForkIOScheduler.hs line 440 -2018-11-05T10:50:42 DEBUG scheduler loop returned ForkIOScheduler.hs line 133 -2018-11-05T10:50:42 DEBUG scheduler cleanup begin ForkIOScheduler.hs line 137 -2018-11-05T10:50:42 NOTICE cancelling processes: [] ForkIOScheduler.hs line 149 -2018-11-05T10:50:42 DEBUG scheduler cleanup done ForkIOScheduler.hs line 141 +DEBUG scheduler loop entered ForkIOScheduler.hs line 157 +DEBUG !1 enter process ForkIOScheduler.hs line 549 +NOTICE !1 ++++++++ main process started ++++++++ ForkIOScheduler.hs line 461 +DEBUG !2 enter process ForkIOScheduler.hs line 549 +INFO !2 I am waiting for someone to ask me... Main.hs line 26 +INFO !2 !1 just needed to know it. Main.hs line 29 +DEBUG !2 exit normally ForkIOScheduler.hs line 568 +INFO !1 I just met Alice Main.hs line 34 +NOTICE !1 ++++++++ main process returned ++++++++ ForkIOScheduler.hs line 463 +DEBUG !1 exit normally ForkIOScheduler.hs line 568 +DEBUG scheduler loop returned ForkIOScheduler.hs line 159 +DEBUG scheduler cleanup begin ForkIOScheduler.hs line 154 +NOTICE cancelling processes: [] ForkIOScheduler.hs line 168 +NOTICE all processes cancelled ForkIOScheduler.hs line 179 ``` ## TODO diff --git a/examples/example-3/Main.hs b/examples/example-3/Main.hs --- a/examples/example-3/Main.hs +++ b/examples/example-3/Main.hs @@ -9,9 +9,9 @@ runLift $ withSomeLogging @IO $ withLogFileAppender "extensible-effects-concurrent-example-3.log" - $ addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("traced: "++)) debugTraceLogWriter)) + $ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("traced: "++)) debugTraceLogWriter)) $ modifyLogWriter (defaultIoLogWriter "example-3" local0) - $ addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("traced without timestamp: "++)) debugTraceLogWriter)) + $ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("traced without timestamp: "++)) debugTraceLogWriter)) $ do logEmergency "test emergencySeverity 1" logCritical "test criticalSeverity 2" @@ -22,5 +22,5 @@ logDebug "test debugSeverity 7" -testPred :: LogPredicate -testPred = view (lmSeverity . to (<= errorSeverity)) +severeMessages :: LogPredicate +severeMessages = view (lmSeverity . to (<= errorSeverity)) diff --git a/examples/example-4/Main.hs b/examples/example-4/Main.hs --- a/examples/example-4/Main.hs +++ b/examples/example-4/Main.hs @@ -3,7 +3,6 @@ import Control.Eff import Control.Eff.Concurrent import Data.Dynamic -import Control.Concurrent import Control.DeepSeq import GHC.Stack (HasCallStack) @@ -11,11 +10,7 @@ main = defaultMainWithLogWriter (defaultIoLogWriter "example-4" local0 consoleLogWriter) - $ do - lift (threadDelay 100000) -- because of async logging - firstExample - lift (threadDelay 100000) -- ... async logging - + firstExample newtype WhoAreYou = WhoAreYou ProcessId deriving (Typeable, NFData, Show) diff --git a/extensible-effects-concurrent.cabal b/extensible-effects-concurrent.cabal --- a/extensible-effects-concurrent.cabal +++ b/extensible-effects-concurrent.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: extensible-effects-concurrent -version: 0.19.0 +version: 0.19.1 description: Please see the README on GitHub at synopsis: Message passing concurrency as extensible-effect homepage: https://github.com/sheyll/extensible-effects-concurrent#readme @@ -8,7 +8,7 @@ author: Sven Heyll maintainer: sven.heyll@gmail.com category: Concurrency, Control, Effect -tested-with: GHC==8.6.4 +tested-with: GHC==8.6.3, GHC==8.6.4 copyright: Copyright Sven Heyll license: BSD3 license-file: LICENSE diff --git a/src/Control/Eff/Concurrent/Api.hs b/src/Control/Eff/Concurrent/Api.hs --- a/src/Control/Eff/Concurrent/Api.hs +++ b/src/Control/Eff/Concurrent/Api.hs @@ -2,10 +2,10 @@ -- /requests/) a 'Server' ('Process') can handle, and if the caller blocks and -- waits for an answer, which the server process provides. -- --- The type magic in the 'Api' type familiy allows to define a related set of /requests/ along +-- The type magic in the 'Api' type family allows to define a related set of /requests/ along -- with the corresponding responses. -- --- Request handling can be either blocking, if a response is requred, or +-- Request handling can be either blocking, if a response is required, or -- non-blocking. -- -- A process can /serve/ a specific 'Api' instance by using the functions provided by diff --git a/src/Control/Eff/Concurrent/Api/Client.hs b/src/Control/Eff/Concurrent/Api/Client.hs --- a/src/Control/Eff/Concurrent/Api/Client.hs +++ b/src/Control/Eff/Concurrent/Api/Client.hs @@ -71,8 +71,8 @@ extractResult (Reply _pxResult callRefMsg result) = if callRefMsg == callRef then Just result else Nothing in selectMessageWith extractResult - rres <- receiveWithMonitor pidInternal selectResult - either (interrupt . becauseProcessIsDown) return rres + resultOrError <- receiveWithMonitor pidInternal selectResult + either (interrupt . becauseProcessIsDown) return resultOrError -- | Instead of passing around a 'Server' value and passing to functions like -- 'cast' or 'call', a 'Server' can provided by a 'Reader' effect, if there is diff --git a/src/Control/Eff/Concurrent/Api/Observer.hs b/src/Control/Eff/Concurrent/Api/Observer.hs --- a/src/Control/Eff/Concurrent/Api/Observer.hs +++ b/src/Control/Eff/Concurrent/Api/Observer.hs @@ -61,7 +61,7 @@ (==) (Observer _ s1) (Observer _ s2) = (==) (s1 ^. fromServer) (s2 ^. fromServer) --- | And an 'Observer' to the set of reciepients for all observations reported by 'observed'. +-- | And an 'Observer' to the set of recipients for all observations reported by 'observed'. -- Note that the observers are keyed by the observing process, i.e. a previous entry for the process -- contained in the 'Observer' is overwritten. If you want multiple entries for a single process, just -- combine several filter functions. diff --git a/src/Control/Eff/Concurrent/Process/Interactive.hs b/src/Control/Eff/Concurrent/Process/Interactive.hs --- a/src/Control/Eff/Concurrent/Process/Interactive.hs +++ b/src/Control/Eff/Concurrent/Process/Interactive.hs @@ -93,12 +93,12 @@ case mInQueue of Nothing -> return (Left True) Just (SchedulerQueue inQueue) -> do - mnextAction <- tryReadTChan inQueue - case mnextAction of + mNextAction <- tryReadTChan inQueue + case mNextAction of Nothing -> return (Left False) Just nextAction -> return (Right nextAction) --- | Exit the schedulder immediately using an asynchronous exception. +-- | Exit the scheduler immediately using an asynchronous exception. killInteractiveScheduler :: SchedulerSession r -> IO () killInteractiveScheduler (SchedulerSession qVar) = atomically (void (tryTakeTMVar qVar)) diff --git a/src/Control/Eff/Log.hs b/src/Control/Eff/Log.hs --- a/src/Control/Eff/Log.hs +++ b/src/Control/Eff/Log.hs @@ -187,7 +187,7 @@ $ runCapturedLogsWriter $ withLogging listLogWriter $ addLogWriter (mappingLogWriter (lmMessage %~ ("CAPTURED "++)) listLogWriter) - $ addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("TRACED "++)) debugTraceLogWriter)) + $ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("TRACED "++)) debugTraceLogWriter)) $ do logEmergency "test emergencySeverity 1" logCritical "test criticalSeverity 2" @@ -196,7 +196,7 @@ logWarning "test warningSeverity 5" logInfo "test informationalSeverity 6" logDebug "test debugSeverity 7" - testPred = view (lmSeverity . to (<= errorSeverity)) + severeMessages = view (lmSeverity . to (<= errorSeverity)) -- | Example code for: diff --git a/src/Control/Eff/Log/Handler.hs b/src/Control/Eff/Log/Handler.hs --- a/src/Control/Eff/Log/Handler.hs +++ b/src/Control/Eff/Log/Handler.hs @@ -91,7 +91,7 @@ -- | 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" +-- for more information about log predicates, see "Control.Eff.Log.Handler#LogPredicate" -- -- This effect is handled via 'withLogging'. data Logs v where @@ -687,7 +687,7 @@ -- > $ runCapturedLogsWriter -- > $ withLogging listLogWriter -- > $ addLogWriter (mappingLogWriter (lmMessage %~ ("CAPTURED "++)) listLogWriter) --- > $ addLogWriter (filteringLogWriter testPred (mappingLogWriter (lmMessage %~ ("TRACED "++)) debugTraceLogWriter)) +-- > $ addLogWriter (filteringLogWriter severeMessages (mappingLogWriter (lmMessage %~ ("TRACED "++)) debugTraceLogWriter)) -- > $ do -- > logEmergency "test emergencySeverity 1" -- > logCritical "test criticalSeverity 2" @@ -696,7 +696,7 @@ -- > logWarning "test warningSeverity 5" -- > logInfo "test informationalSeverity 6" -- > logDebug "test debugSeverity 7" --- > testPred = view (lmSeverity . to (<= errorSeverity)) +-- > severeMessages = view (lmSeverity . to (<= errorSeverity)) -- > -- addLogWriter :: forall h e a . diff --git a/src/Control/Eff/Log/Message.hs b/src/Control/Eff/Log/Message.hs --- a/src/Control/Eff/Log/Message.hs +++ b/src/Control/Eff/Log/Message.hs @@ -426,7 +426,7 @@ -- > debugLogsForAppName myAppName lm = -- > view lmAppName lm == Just myAppName || lmSeverityIsAtLeast warningSeverity lm -- --- This is implemented in 'discriminateByAppName'. +-- This concept is also implemented in 'discriminateByAppName'. lmAppName :: Functor f => (Maybe String -> f (Maybe String)) -> LogMessage -> f LogMessage @@ -604,43 +604,49 @@ type LogPredicate = LogMessage -> Bool -- | All messages. +-- +-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates. allLogMessages :: LogPredicate allLogMessages = const True -- | No messages. +-- +-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates. noLogMessages :: LogPredicate noLogMessages = const False -- | Match 'LogMessage's that have exactly the given severity. -- See 'lmSeverityIsAtLeast'. -- --- See "Control.Eff.Log.Handler#LogPredicate" +-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates. 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" +-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates. 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" +-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates. 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 +-- | Apply a 'LogPredicate' based on the '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. +-- +-- See "Control.Eff.Log.Message#PredefinedPredicates" for more predicates. discriminateByAppName :: String -> LogPredicate -> LogPredicate -> LogPredicate discriminateByAppName appName appPredicate otherPredicate lm = if view lmAppName lm == Just appName diff --git a/src/Control/Eff/Loop.hs b/src/Control/Eff/Loop.hs --- a/src/Control/Eff/Loop.hs +++ b/src/Control/Eff/Loop.hs @@ -6,7 +6,7 @@ -- the @-fno-full-laziness@ GHC option. -- -- There is a unit test in the sources of this module, which can be used to do a --- comperative heap profiling of these function vs. their counterparts in the +-- comparative heap profiling of these function vs. their counterparts in the -- @base@ package. -- -- Here are the images of the profiling results, the images show that the diff --git a/test/ForkIOScheduler.hs b/test/ForkIOScheduler.hs --- a/test/ForkIOScheduler.hs +++ b/test/ForkIOScheduler.hs @@ -40,8 +40,8 @@ me <- self spawn_ (lift (threadDelay 10000) >> sendMessage me ()) - eres <- receiveWithMonitor p1 (selectMessage @()) - case eres of + resultOrError <- receiveWithMonitor p1 (selectMessage @()) + case resultOrError of Left _down -> lift (atomically (putTMVar aVar False)) Right () -> withMonitor p1 $ \ref -> do sendShutdown p1 (NotRecovered (ProcessError "test 123")) @@ -161,11 +161,11 @@ let n = 100 testMsg :: Float testMsg = 123 - flushMsgs = do + flushMessages = do res <- receiveSelectedAfter (selectDynamicMessageLazy Just) 0 case res of Left _to -> return () - Right _ -> flushMsgs + Right _ -> flushMessages me <- self spawn_ (do @@ -176,7 +176,7 @@ do res <- receiveAfter @Float 1000000 lift (res @?= Just testMsg) - flushMsgs + flushMessages res <- receiveSelectedAfter (selectDynamicMessageLazy Just) 10000 case res of Left _ -> return () diff --git a/test/SingleThreadedScheduler.hs b/test/SingleThreadedScheduler.hs --- a/test/SingleThreadedScheduler.hs +++ b/test/SingleThreadedScheduler.hs @@ -22,14 +22,14 @@ sendMessage from ((arg1 + arg2) :: Int) foreverCheap $ void $ receiveAnyMessage - multChild <- spawn $ do + multiplierChild <- spawn $ do (from, arg1, arg2) <- receiveMessage sendMessage from ((arg1 * arg2) :: Int) me <- self sendMessage adderChild (me, 3 :: Int, 4 :: Int) x <- receiveMessage @Int - sendMessage multChild (me, x, 6 :: Int) + sendMessage multiplierChild (me, x, 6 :: Int) receiveMessage @Int ) ]