extensible-effects-concurrent 0.19.0 → 0.19.1
raw patch · 16 files changed
+78/−68 lines, 16 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- .travis.yml +1/−1
- ChangeLog.md +17/−2
- README.md +21/−27
- examples/example-3/Main.hs +4/−4
- examples/example-4/Main.hs +1/−6
- extensible-effects-concurrent.cabal +2/−2
- src/Control/Eff/Concurrent/Api.hs +2/−2
- src/Control/Eff/Concurrent/Api/Client.hs +2/−2
- src/Control/Eff/Concurrent/Api/Observer.hs +1/−1
- src/Control/Eff/Concurrent/Process/Interactive.hs +3/−3
- src/Control/Eff/Log.hs +2/−2
- src/Control/Eff/Log/Handler.hs +3/−3
- src/Control/Eff/Log/Message.hs +11/−5
- src/Control/Eff/Loop.hs +1/−1
- test/ForkIOScheduler.hs +5/−5
- test/SingleThreadedScheduler.hs +2/−2
.travis.yml view
@@ -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:
ChangeLog.md view
@@ -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`
README.md view
@@ -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
examples/example-3/Main.hs view
@@ -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))
examples/example-4/Main.hs view
@@ -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)
extensible-effects-concurrent.cabal view
@@ -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 <https://github.com/sheyll/extensible-effects-concurrent#readme> 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
src/Control/Eff/Concurrent/Api.hs view
@@ -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
src/Control/Eff/Concurrent/Api/Client.hs view
@@ -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
src/Control/Eff/Concurrent/Api/Observer.hs view
@@ -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.
src/Control/Eff/Concurrent/Process/Interactive.hs view
@@ -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))
src/Control/Eff/Log.hs view
@@ -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:
src/Control/Eff/Log/Handler.hs view
@@ -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 .
src/Control/Eff/Log/Message.hs view
@@ -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
src/Control/Eff/Loop.hs view
@@ -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
test/ForkIOScheduler.hs view
@@ -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 ()
test/SingleThreadedScheduler.hs view
@@ -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 ) ]