unliftio-messagebox 1.0.2 → 2.0.0
raw patch · 19 files changed
+147/−113 lines, 19 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- UnliftIO.MessageBox: CatchAllFactory :: cfg -> CatchAllFactory cfg
- UnliftIO.MessageBox: class (IsMessageBox (MessageBox cfg), IsInput (Input (MessageBox cfg))) => IsMessageBoxFactory cfg where {
- UnliftIO.MessageBox: newtype CatchAllFactory cfg
- UnliftIO.MessageBox.CatchAll: CatchAllFactory :: cfg -> CatchAllFactory cfg
- UnliftIO.MessageBox.CatchAll: instance GHC.Classes.Eq cfg => GHC.Classes.Eq (UnliftIO.MessageBox.CatchAll.CatchAllFactory cfg)
- UnliftIO.MessageBox.CatchAll: instance GHC.Classes.Ord cfg => GHC.Classes.Ord (UnliftIO.MessageBox.CatchAll.CatchAllFactory cfg)
- UnliftIO.MessageBox.CatchAll: instance GHC.Show.Show cfg => GHC.Show.Show (UnliftIO.MessageBox.CatchAll.CatchAllFactory cfg)
- UnliftIO.MessageBox.CatchAll: instance UnliftIO.MessageBox.Class.IsMessageBoxFactory cfg => UnliftIO.MessageBox.Class.IsMessageBoxFactory (UnliftIO.MessageBox.CatchAll.CatchAllFactory cfg)
- UnliftIO.MessageBox.CatchAll: newtype CatchAllFactory cfg
- UnliftIO.MessageBox.Class: class (IsMessageBox (MessageBox cfg), IsInput (Input (MessageBox cfg))) => IsMessageBoxFactory cfg where {
- UnliftIO.MessageBox.Limited: instance UnliftIO.MessageBox.Class.IsMessageBoxFactory UnliftIO.MessageBox.Limited.BlockingBoxLimit
- UnliftIO.MessageBox.Limited: instance UnliftIO.MessageBox.Class.IsMessageBoxFactory UnliftIO.MessageBox.Limited.NonBlockingBoxLimit
- UnliftIO.MessageBox.Limited: instance UnliftIO.MessageBox.Class.IsMessageBoxFactory UnliftIO.MessageBox.Limited.WaitingBoxLimit
- UnliftIO.MessageBox.Unlimited: instance UnliftIO.MessageBox.Class.IsMessageBoxFactory UnliftIO.MessageBox.Unlimited.BlockingUnlimited
+ UnliftIO.MessageBox: CatchAllArg :: cfg -> CatchAllArg cfg
+ UnliftIO.MessageBox: class (IsMessageBox (MessageBox argument), IsInput (Input (MessageBox argument))) => IsMessageBoxArg argument where {
+ UnliftIO.MessageBox: deliver_ :: (IsInput input, MonadUnliftIO m) => input a -> a -> m ()
+ UnliftIO.MessageBox: newtype CatchAllArg cfg
+ UnliftIO.MessageBox.CatchAll: CatchAllArg :: cfg -> CatchAllArg cfg
+ UnliftIO.MessageBox.CatchAll: instance GHC.Classes.Eq cfg => GHC.Classes.Eq (UnliftIO.MessageBox.CatchAll.CatchAllArg cfg)
+ UnliftIO.MessageBox.CatchAll: instance GHC.Classes.Ord cfg => GHC.Classes.Ord (UnliftIO.MessageBox.CatchAll.CatchAllArg cfg)
+ UnliftIO.MessageBox.CatchAll: instance GHC.Show.Show cfg => GHC.Show.Show (UnliftIO.MessageBox.CatchAll.CatchAllArg cfg)
+ UnliftIO.MessageBox.CatchAll: instance UnliftIO.MessageBox.Class.IsMessageBoxArg cfg => UnliftIO.MessageBox.Class.IsMessageBoxArg (UnliftIO.MessageBox.CatchAll.CatchAllArg cfg)
+ UnliftIO.MessageBox.CatchAll: newtype CatchAllArg cfg
+ UnliftIO.MessageBox.Class: class (IsMessageBox (MessageBox argument), IsInput (Input (MessageBox argument))) => IsMessageBoxArg argument where {
+ UnliftIO.MessageBox.Class: deliver_ :: (IsInput input, MonadUnliftIO m) => input a -> a -> m ()
+ UnliftIO.MessageBox.Limited: instance UnliftIO.MessageBox.Class.IsMessageBoxArg UnliftIO.MessageBox.Limited.BlockingBoxLimit
+ UnliftIO.MessageBox.Limited: instance UnliftIO.MessageBox.Class.IsMessageBoxArg UnliftIO.MessageBox.Limited.NonBlockingBoxLimit
+ UnliftIO.MessageBox.Limited: instance UnliftIO.MessageBox.Class.IsMessageBoxArg UnliftIO.MessageBox.Limited.WaitingBoxLimit
+ UnliftIO.MessageBox.Unlimited: instance UnliftIO.MessageBox.Class.IsMessageBoxArg UnliftIO.MessageBox.Unlimited.BlockingUnlimited
- UnliftIO.MessageBox: -- | Type of the corresponding input
+ UnliftIO.MessageBox: -- | The message box that can be created from the message box argument
- UnliftIO.MessageBox: class IsInput (Input msgBox) => IsMessageBox msgBox where {
+ UnliftIO.MessageBox: class IsInput (Input box) => IsMessageBox box where {
- UnliftIO.MessageBox: getConfiguredMessageLimit :: IsMessageBoxFactory cfg => cfg -> Maybe Int
+ UnliftIO.MessageBox: getConfiguredMessageLimit :: IsMessageBoxArg argument => argument -> Maybe Int
- UnliftIO.MessageBox: handleMessage :: (MonadUnliftIO m, IsMessageBox msgBox) => msgBox message -> (message -> m b) -> m (Maybe b)
+ UnliftIO.MessageBox: handleMessage :: (MonadUnliftIO m, IsMessageBox box) => box message -> (message -> m b) -> m (Maybe b)
- UnliftIO.MessageBox: newInput :: (IsMessageBox msgBox, MonadUnliftIO m) => msgBox a -> m (Input msgBox a)
+ UnliftIO.MessageBox: newInput :: (IsMessageBox box, MonadUnliftIO m) => box a -> m (Input box a)
- UnliftIO.MessageBox: newMessageBox :: (IsMessageBoxFactory cfg, MonadUnliftIO m) => cfg -> m (MessageBox cfg a)
+ UnliftIO.MessageBox: newMessageBox :: (IsMessageBoxArg argument, MonadUnliftIO m) => argument -> m (MessageBox argument a)
- UnliftIO.MessageBox: receive :: (IsMessageBox msgBox, MonadUnliftIO m) => msgBox a -> m (Maybe a)
+ UnliftIO.MessageBox: receive :: (IsMessageBox box, MonadUnliftIO m) => box a -> m (Maybe a)
- UnliftIO.MessageBox: receiveAfter :: (IsMessageBox msgBox, MonadUnliftIO m) => msgBox a -> Int -> m (Maybe a)
+ UnliftIO.MessageBox: receiveAfter :: (IsMessageBox box, MonadUnliftIO m) => box a -> Int -> m (Maybe a)
- UnliftIO.MessageBox: tryReceive :: (IsMessageBox msgBox, MonadUnliftIO m) => msgBox a -> m (Future a)
+ UnliftIO.MessageBox: tryReceive :: (IsMessageBox box, MonadUnliftIO m) => box a -> m (Future a)
- UnliftIO.MessageBox: type family MessageBox cfg :: Type -> Type;
+ UnliftIO.MessageBox: type family MessageBox argument :: Type -> Type;
- UnliftIO.MessageBox.Class: class IsInput (Input msgBox) => IsMessageBox msgBox where {
+ UnliftIO.MessageBox.Class: class IsInput (Input box) => IsMessageBox box where {
- UnliftIO.MessageBox.Class: getConfiguredMessageLimit :: IsMessageBoxFactory cfg => cfg -> Maybe Int
+ UnliftIO.MessageBox.Class: getConfiguredMessageLimit :: IsMessageBoxArg argument => argument -> Maybe Int
- UnliftIO.MessageBox.Class: handleMessage :: (MonadUnliftIO m, IsMessageBox msgBox) => msgBox message -> (message -> m b) -> m (Maybe b)
+ UnliftIO.MessageBox.Class: handleMessage :: (MonadUnliftIO m, IsMessageBox box) => box message -> (message -> m b) -> m (Maybe b)
- UnliftIO.MessageBox.Class: newInput :: (IsMessageBox msgBox, MonadUnliftIO m) => msgBox a -> m (Input msgBox a)
+ UnliftIO.MessageBox.Class: newInput :: (IsMessageBox box, MonadUnliftIO m) => box a -> m (Input box a)
- UnliftIO.MessageBox.Class: newMessageBox :: (IsMessageBoxFactory cfg, MonadUnliftIO m) => cfg -> m (MessageBox cfg a)
+ UnliftIO.MessageBox.Class: newMessageBox :: (IsMessageBoxArg argument, MonadUnliftIO m) => argument -> m (MessageBox argument a)
- UnliftIO.MessageBox.Class: receive :: (IsMessageBox msgBox, MonadUnliftIO m) => msgBox a -> m (Maybe a)
+ UnliftIO.MessageBox.Class: receive :: (IsMessageBox box, MonadUnliftIO m) => box a -> m (Maybe a)
- UnliftIO.MessageBox.Class: receiveAfter :: (IsMessageBox msgBox, MonadUnliftIO m) => msgBox a -> Int -> m (Maybe a)
+ UnliftIO.MessageBox.Class: receiveAfter :: (IsMessageBox box, MonadUnliftIO m) => box a -> Int -> m (Maybe a)
- UnliftIO.MessageBox.Class: tryReceive :: (IsMessageBox msgBox, MonadUnliftIO m) => msgBox a -> m (Future a)
+ UnliftIO.MessageBox.Class: tryReceive :: (IsMessageBox box, MonadUnliftIO m) => box a -> m (Future a)
- UnliftIO.MessageBox.Class: type family Input msgBox :: Type -> Type;
+ UnliftIO.MessageBox.Class: type family Input box :: Type -> Type;
Files
- README.md +14/−10
- src-benchmark/BookStoreBenchmark.hs +4/−4
- src-benchmark/CommandBenchmark.hs +4/−4
- src-benchmark/Main.hs +5/−5
- src-benchmark/MediaBenchmark.hs +3/−3
- src-memleak-test/MediaBenchmark.hs +1/−1
- src-test/CatchAllTest.hs +1/−1
- src-test/CommandTest.hs +1/−1
- src-test/CornerCaseTests.hs +5/−5
- src-test/LimitedMessageBoxTest.hs +2/−2
- src-test/MessageBoxClassTest.hs +6/−6
- src-test/QCOrphans.hs +3/−3
- src-test/Utils.hs +37/−8
- src/UnliftIO/MessageBox.hs +3/−3
- src/UnliftIO/MessageBox/CatchAll.hs +8/−8
- src/UnliftIO/MessageBox/Class.hs +28/−19
- src/UnliftIO/MessageBox/Limited.hs +6/−6
- src/UnliftIO/MessageBox/Unlimited.hs +2/−2
- unliftio-messagebox.cabal +14/−22
README.md view
@@ -1,6 +1,11 @@+[](https://github.com/sheyll/unliftio-messagebox/actions)+[](https://github.com/sheyll/unliftio-messagebox/actions)+ # Fast and Robust Message Queues for Concurrent Processes -**NOTE:** To be able to fully view this README, use the [web page](https://sheyll.github.io/unliftio-messagebox/).+**NOTE:** To be able to fully view this README, use the [GitHub Pages Version](https://sheyll.github.io/unliftio-messagebox/).+* [API docs](./generated-reports/haddock-report/unliftio-messagebox)+* [API docs on Hackage](http://hackage.haskell.org/package/unliftio-messagebox) A thin wrapper around a subset of `unagi-chan` based on `unliftio`. @@ -14,7 +19,6 @@ thread starvation, as well as acceptable performance even in massively concurrent programs. -Additionally in ## Module Structure The library is contained in modules with names starting with @@ -47,7 +51,7 @@ [Test Profiling Report](./generated-reports/test-profiling-report/unliftio-messagebox-test.prof) -## Memory Leak Test +## Memory Leak Tests This is a small application with a 1002 processes, each performing a fix amount of work.@@ -55,19 +59,19 @@ When the work is done, all processes synchronise before starting a new iteration. After each iteration, the memory usage is queried from the GHC runtime statistics.-There are 100 iterations like that. +There are 10 iterations like that. After that all processes are shutdown, and the process-starts all over again, 30 times.+starts all over again, 5 times. -In total 3000 iterations.+In total 50 iterations. If memory is leaked it should become visible. -The test program is executated with the `+RTS -M400m` option that instructs-the runtime to limit the available heap to 400MB, so when there is a memory+The test program is executed with the `+RTS -Mxxxm` option that instructs+the runtime to limit the available heap to `xxx` MB, so if there is a memory leak, the program would at some point crash with a heap exhaustion error. -+ -The output is printed into [this log file](./generated-reports/memleak-test-report/test.log).+The output is printed into [this log file](./generated-reports/messagebox-memleak-test-report/test.log).
src-benchmark/BookStoreBenchmark.hs view
@@ -50,7 +50,7 @@ ) import UnliftIO.MessageBox.Class ( IsMessageBox(newInput, receive),- IsMessageBoxFactory(newMessageBox),+ IsMessageBoxArg(newMessageBox), handleMessage ) import UnliftIO ( MonadIO (liftIO),@@ -98,7 +98,7 @@ getCallIdCounter MkBookStoreEnv {_fresh} = _fresh onlyCasts ::- (MonadUnliftIO m, IsMessageBoxFactory cfg) =>+ (MonadUnliftIO m, IsMessageBoxArg cfg) => (Int -> Book) -> cfg -> (Int, Int, Int) ->@@ -140,7 +140,7 @@ runConc (producers <> consumers) castsAndCalls ::- (MonadUnliftIO m, IsMessageBoxFactory cfg) =>+ (MonadUnliftIO m, IsMessageBoxArg cfg) => (Int -> Book) -> cfg -> ((Int, Int), Int, (Int, Int)) ->@@ -213,7 +213,7 @@ let donors = mconcat (donor bookStoresInputes <$> [0 .. nDonors - 1]) runConc (donors <> customers <> mconcat bookStoresConc) -benchmark :: IsMessageBoxFactory cfg => cfg -> Benchmark+benchmark :: IsMessageBoxArg cfg => cfg -> Benchmark benchmark cfg = bgroup "BookStore"
src-benchmark/CommandBenchmark.hs view
@@ -28,10 +28,10 @@ ) import qualified MediaBenchmark import UnliftIO.MessageBox.CatchAll- ( CatchAllFactory (CatchAllFactory),+ ( CatchAllArg (CatchAllArg), ) import UnliftIO.MessageBox.Class- ( IsMessageBoxFactory (..),+ ( IsMessageBoxArg (..), ) import qualified UnliftIO.MessageBox.Limited as L import qualified UnliftIO.MessageBox.Unlimited as U@@ -49,11 +49,11 @@ go :: SomeBench -> [Benchmark] go (SomeBench b) = [ (\x -> bgroup "Unlimited" [b x]) U.BlockingUnlimited,- (\x -> bgroup "CatchUnlimited" [b x]) (CatchAllFactory U.BlockingUnlimited),+ (\x -> bgroup "CatchUnlimited" [b x]) (CatchAllArg U.BlockingUnlimited), -- (\x -> bgroup (show x) [b x]) (L.BlockingBoxLimit L.MessageLimit_256), -- (\x -> bgroup (show x) [b x]) (L.WaitingBoxLimit Nothing 5_000_000 L.MessageLimit_256), (\x -> bgroup "Waiting256" [b x]) (L.WaitingBoxLimit (Just 60_000_000) 5_000_000 L.MessageLimit_256) ] newtype SomeBench = SomeBench- {_fromSomeBench :: forall cfg. (Show cfg, IsMessageBoxFactory cfg) => (cfg -> Benchmark)}+ {_fromSomeBench :: forall cfg. (Show cfg, IsMessageBoxArg cfg) => (cfg -> Benchmark)}
src-benchmark/Main.hs view
@@ -31,12 +31,12 @@ ) import Data.Semigroup (Semigroup (stimes)) import UnliftIO.MessageBox.CatchAll- ( CatchAllFactory (..),+ ( CatchAllArg (..), ) import UnliftIO.MessageBox.Class ( IsInput (..), IsMessageBox (..),- IsMessageBoxFactory (..),+ IsMessageBoxArg (..), deliver, newInput, receive,@@ -66,7 +66,7 @@ (isNonBlocking, mboxImplTitle, impl) <- [ let x = U.BlockingUnlimited in (False, "Unlimited", unidirectionalMessagePassing mkTestMessage x),- let x = CatchAllFactory U.BlockingUnlimited+ let x = CatchAllArg U.BlockingUnlimited in (False, "CatchUnlimited", unidirectionalMessagePassing mkTestMessage x), -- let x = L.BlockingBoxLimit L.MessageLimit_1 -- in (False, show x, unidirectionalMessagePassing mkTestMessage x),@@ -91,7 +91,7 @@ -- in (False, show x, unidirectionalMessagePassing mkTestMessage x), let x = L.WaitingBoxLimit (Just 60_000_000) 5_000_000 L.MessageLimit_256 in (True, "Waiting256", unidirectionalMessagePassing mkTestMessage x)- -- let x = CatchAllFactory (L.BlockingBoxLimit L.MessageLimit_128)+ -- let x = CatchAllArg (L.BlockingBoxLimit L.MessageLimit_128) -- in (False, show x, unidirectionalMessagePassing mkTestMessage x) ], (senderNo, receiverNo) <-@@ -121,7 +121,7 @@ deriving newtype (Show) unidirectionalMessagePassing ::- (MonadUnliftIO m, IsMessageBoxFactory cfg) =>+ (MonadUnliftIO m, IsMessageBoxArg cfg) => (Int -> TestMessage) -> cfg -> (Int, Int, Int) ->
src-benchmark/MediaBenchmark.hs view
@@ -69,7 +69,7 @@ import UnliftIO.MessageBox.Class ( IsInput (..), IsMessageBox (..),- IsMessageBoxFactory (..),+ IsMessageBoxArg (..), handleMessage, newInput, receiveAfter,@@ -83,7 +83,7 @@ ) import UnliftIO.Concurrent (forkIO) -benchmark :: (IsMessageBoxFactory cfg) => cfg -> Benchmark+benchmark :: (IsMessageBoxArg cfg) => cfg -> Benchmark benchmark cfg = bgroup "Media"@@ -134,7 +134,7 @@ -- and wait for every process to finish. mediaAppBenchmark :: forall cfg.- (HasCallStack, IsMessageBoxFactory cfg) =>+ (HasCallStack, IsMessageBoxArg cfg) => cfg -> Param -> IO ()
src-memleak-test/MediaBenchmark.hs view
@@ -100,7 +100,7 @@ -- and wait for every process to finish. mediaAppBenchmark :: forall cfg.- (HasCallStack, IsMessageBoxFactory cfg) =>+ (HasCallStack, IsMessageBoxArg cfg) => cfg -> Param -> IO ()
src-test/CatchAllTest.hs view
@@ -17,7 +17,7 @@ "CatchAll" [ testProperty "Derived Classes Coverage"- (allEqOrdShowMethodsImplemented (Proxy @(CatchAllFactory Int))),+ (allEqOrdShowMethodsImplemented (Proxy @(CatchAllArg Int))), testCase "when the wrapped receive throws an exception,\ \ CatchAlls receive returns Nothing"
src-test/CommandTest.hs view
@@ -33,7 +33,7 @@ import UnliftIO.MessageBox.Util.Fresh (CounterVar, fresh, newCounterVar) import UnliftIO.MessageBox.Class ( IsMessageBox (..),- IsMessageBoxFactory (..),+ IsMessageBoxArg (..), handleMessage, ) import UnliftIO.MessageBox.Limited
src-test/CornerCaseTests.hs view
@@ -27,7 +27,7 @@ ( Input, IsInput (deliver), IsMessageBox (newInput, receive),- IsMessageBoxFactory (..),+ IsMessageBoxArg (..), handleMessage, receiveAfter, )@@ -113,7 +113,7 @@ deriving stock (Show, Eq) waitForMessageFromDeadProcess ::- (HasCallStack, IsMessageBoxFactory cfg) =>+ (HasCallStack, IsMessageBoxArg cfg) => cfg -> IO WaitForMessageFromDeadProcessResult waitForMessageFromDeadProcess outputCfg =@@ -147,7 +147,7 @@ deriving stock (Show, Eq) sendMessagesToDeadProcess ::- (HasCallStack, IsMessageBoxFactory cfg) =>+ (HasCallStack, IsMessageBoxArg cfg) => cfg -> IO SendMessageToDeadProcessResult sendMessagesToDeadProcess outputCfg =@@ -197,7 +197,7 @@ deriving stock (Show, Eq) waitForCallReplyFromDeadServer ::- (IsMessageBoxFactory cfg) =>+ (IsMessageBoxArg cfg) => cfg -> IO WaitForCallReplyFromDeadServerResult waitForCallReplyFromDeadServer outputCfg =@@ -223,7 +223,7 @@ (const (return WaitForCallReplyFromDeadServerResult)) waitForCallReplyFromDeadServerServer ::- (IsMessageBoxFactory cfg) =>+ (IsMessageBoxArg cfg) => cfg -> MVar (Input (MessageBox cfg) (Message TestServer)) -> IO ()
src-test/LimitedMessageBoxTest.hs view
@@ -19,7 +19,7 @@ import UnliftIO.MessageBox.Class ( IsInput (deliver), IsMessageBox (newInput, receive, tryReceive),- IsMessageBoxFactory (MessageBox, newMessageBox),+ IsMessageBoxArg (MessageBox, newMessageBox), receiveAfter, ) import UnliftIO.MessageBox.Limited@@ -65,7 +65,7 @@ testCommon :: forall boxCfg cfg.- ( IsMessageBoxFactory boxCfg,+ ( IsMessageBoxArg boxCfg, Show boxCfg, cfg ~ MessageBox boxCfg ) =>
src-test/MessageBoxClassTest.hs view
@@ -18,12 +18,12 @@ ) import UnliftIO.Concurrent (threadDelay) import UnliftIO.MessageBox.CatchAll- ( CatchAllFactory (CatchAllFactory),+ ( CatchAllArg (CatchAllArg), ) import UnliftIO.MessageBox.Class ( IsInput (..), IsMessageBox (..),- IsMessageBoxFactory (..),+ IsMessageBoxArg (..), deliver, handleMessage, newInput,@@ -44,9 +44,9 @@ "UnliftIO.MessageBox.Class" [ utilTest, testWith U.BlockingUnlimited,- testWith $ CatchAllFactory U.BlockingUnlimited,+ testWith $ CatchAllArg U.BlockingUnlimited, testWith (B.BlockingBoxLimit B.MessageLimit_256),- testWith $ CatchAllFactory (B.BlockingBoxLimit B.MessageLimit_256),+ testWith $ CatchAllArg (B.BlockingBoxLimit B.MessageLimit_256), testWith (B.BlockingBoxLimit B.MessageLimit_1), testWith (B.BlockingBoxLimit B.MessageLimit_2), testWith (B.NonBlockingBoxLimit B.MessageLimit_1),@@ -73,7 +73,7 @@ ] testWith ::- (IsMessageBoxFactory cfg, Show cfg) =>+ (IsMessageBoxArg cfg, Show cfg) => cfg -> TestTree testWith arg =@@ -84,7 +84,7 @@ -- standard tests commonFunctionality ::- (IsMessageBoxFactory cfg) =>+ (IsMessageBoxArg cfg) => cfg -> TestTree commonFunctionality arg =
src-test/QCOrphans.hs view
@@ -4,7 +4,7 @@ module QCOrphans () where import UnliftIO.MessageBox.Util.CallId-import UnliftIO.MessageBox.CatchAll (CatchAllFactory (..))+import UnliftIO.MessageBox.CatchAll (CatchAllArg (..)) import qualified UnliftIO.MessageBox.Limited as Limited import Test.QuickCheck (Arbitrary (arbitrary), elements) @@ -23,8 +23,8 @@ <*> arbitrary <*> arbitrary -instance Arbitrary a => Arbitrary (CatchAllFactory a) where- arbitrary = CatchAllFactory <$> arbitrary+instance Arbitrary a => Arbitrary (CatchAllArg a) where+ arbitrary = CatchAllArg <$> arbitrary instance Arbitrary CallId where arbitrary = MkCallId <$> arbitrary
src-test/Utils.hs view
@@ -11,7 +11,9 @@ withCallIds, allEqOrdShowMethodsImplemented, allEnumMethodsImplemented,- NoOpFactory (..),+ MockBoxInit(..),+ MockBox(..),+ NoOpArg (..), NoOpBox (..), NoOpInput (..), )@@ -26,7 +28,7 @@ import UnliftIO.MessageBox.Class ( IsInput (..), IsMessageBox (Input, newInput, receive, tryReceive),- IsMessageBoxFactory (..),+ IsMessageBoxArg (..), ) import Test.QuickCheck ( Arbitrary,@@ -140,10 +142,37 @@ === enumFromTo x y ) --- message box dummy implementation+-- message box implementation+-- NOTE: Because of parametricity and the existential quantification+-- of the message payload, the receive and deliver methods+-- are only capable of throwing exceptions or bottoming out -data NoOpFactory- = NoOpFactory+data MockBoxInit msgBox = MkMockBoxInit + { mockBoxNew :: forall m a. MonadUnliftIO m => m (msgBox a)+ , mockBoxLimit :: !(Maybe Int)+ }++instance IsMessageBox msgBox => IsMessageBoxArg (MockBoxInit msgBox) where + type MessageBox (MockBoxInit msgBox) = msgBox+ getConfiguredMessageLimit = mockBoxLimit+ newMessageBox b = mockBoxNew b++data MockBox input a = MkMockBox + { mockBoxNewInput :: forall m . MonadUnliftIO m => m (input a)+ , mockBoxReceive :: forall m . MonadUnliftIO m => m (Maybe a)+ , mockBoxTryReceive :: forall m . MonadUnliftIO m => m (Future a)+ }++instance IsInput input => IsMessageBox (MockBox input) where+ type Input (MockBox input) = input+ newInput m = mockBoxNewInput m + receive m = mockBoxReceive m+ tryReceive m = mockBoxTryReceive m++++data NoOpArg+ = NoOpArg deriving stock (Show) newtype NoOpInput a@@ -153,9 +182,9 @@ = OnReceive (Maybe Int) (Maybe a) deriving stock (Show) -instance IsMessageBoxFactory NoOpFactory where- type MessageBox NoOpFactory = NoOpBox- newMessageBox NoOpFactory = return (OnReceive Nothing Nothing)+instance IsMessageBoxArg NoOpArg where+ type MessageBox NoOpArg = NoOpBox+ newMessageBox NoOpArg = return (OnReceive Nothing Nothing) getConfiguredMessageLimit _ = Nothing instance IsMessageBox NoOpBox where
src/UnliftIO/MessageBox.hs view
@@ -27,14 +27,14 @@ where import UnliftIO.MessageBox.CatchAll- ( CatchAllBox (..),- CatchAllFactory (..),+ ( CatchAllArg (..),+ CatchAllBox (..), CatchAllInput (..), ) import UnliftIO.MessageBox.Class ( IsInput (..), IsMessageBox (..),- IsMessageBoxFactory (..),+ IsMessageBoxArg (..), handleMessage, ) import UnliftIO.MessageBox.Command
src/UnliftIO/MessageBox/CatchAll.hs view
@@ -5,7 +5,7 @@ -- This provides a wrapper around "UnliftIO.MessageBox.Class" instances -- to catch 'SomeException' in all methods like 'deliver' and 'receive'. module UnliftIO.MessageBox.CatchAll- ( CatchAllFactory (..),+ ( CatchAllArg (..), CatchAllBox (..), CatchAllInput (..), )@@ -15,16 +15,16 @@ import UnliftIO.MessageBox.Class ( IsInput (..), IsMessageBox (..),- IsMessageBoxFactory (..),+ IsMessageBoxArg (..), ) import UnliftIO (SomeException, liftIO, try) import UnliftIO.Concurrent (threadDelay) -- | A wrapper around values that are instances--- of 'IsMessageBoxFactory'. The factory wraps+-- of 'IsMessageBoxArg'. The factory wraps -- the result of the delegated 'newMessageBox' -- invocation into a 'CatchAllBox'.-newtype CatchAllFactory cfg = CatchAllFactory cfg+newtype CatchAllArg cfg = CatchAllArg cfg deriving stock (Eq, Ord, Show) -- | A wrapper around values that are instances@@ -38,11 +38,11 @@ -- of 'IsInput'. newtype CatchAllInput i a = CatchAllInput (i a) -instance IsMessageBoxFactory cfg => IsMessageBoxFactory (CatchAllFactory cfg) where- type MessageBox (CatchAllFactory cfg) = CatchAllBox (MessageBox cfg)+instance IsMessageBoxArg cfg => IsMessageBoxArg (CatchAllArg cfg) where+ type MessageBox (CatchAllArg cfg) = CatchAllBox (MessageBox cfg) {-# INLINE newMessageBox #-}- newMessageBox (CatchAllFactory !cfg) = CatchAllBox <$> newMessageBox cfg- getConfiguredMessageLimit (CatchAllFactory !cfg) =+ newMessageBox (CatchAllArg !cfg) = CatchAllBox <$> newMessageBox cfg+ getConfiguredMessageLimit (CatchAllArg !cfg) = getConfiguredMessageLimit cfg instance IsMessageBox box => IsMessageBox (CatchAllBox box) where
src/UnliftIO/MessageBox/Class.hs view
@@ -2,7 +2,7 @@ -- describes exchangable operations on messages -- boxes. module UnliftIO.MessageBox.Class- ( IsMessageBoxFactory (..),+ ( IsMessageBoxArg (..), IsMessageBox (..), IsInput (..), handleMessage,@@ -12,17 +12,22 @@ import Data.Kind (Type) import UnliftIO.MessageBox.Util.Future (Future, awaitFuture) import UnliftIO (MonadUnliftIO, timeout)+import Control.Monad (void) --- | Create 'IsMessageBox' instances from a parameter.+-- | Types that configure and allow the creation of a 'MessageBox'.+--+-- Create 'IsMessageBox' instances from a parameter. -- Types that determine 'MessageBox' values. -- -- For a limited message box this might be the limit of -- the message queue. class- (IsMessageBox (MessageBox cfg), IsInput (Input (MessageBox cfg))) =>- IsMessageBoxFactory cfg+ (IsMessageBox (MessageBox argument), IsInput (Input (MessageBox argument))) =>+ IsMessageBoxArg argument where- type MessageBox cfg :: Type -> Type+ -- | The message box that can be created from the+ -- message box argument+ type MessageBox argument :: Type -> Type -- | Return a message limit. --@@ -32,18 +37,18 @@ -- Also note that the naming follows the rule: -- Reserve short names for entities that are -- used often.- getConfiguredMessageLimit :: cfg -> Maybe Int+ getConfiguredMessageLimit :: argument -> Maybe Int - -- | Create a new @msgBox@.+ -- | Create a new @msgBox@ according to the @argument@. -- This is required to receive a message. -- NOTE: Only one process may receive on an msgBox.- newMessageBox :: MonadUnliftIO m => cfg -> m (MessageBox cfg a)+ newMessageBox :: MonadUnliftIO m => argument -> m (MessageBox argument a) -- | A type class for msgBox types. -- A common interface for receiving messages.-class IsInput (Input msgBox) => IsMessageBox msgBox where+class IsInput (Input box) => IsMessageBox box where -- | Type of the corresponding input- type Input msgBox :: Type -> Type+ type Input box :: Type -> Type -- | Receive a message. Take whatever time it takes. -- Return 'Just' the value or 'Nothing' when an error@@ -53,14 +58,14 @@ -- when there is a lot of load, so please make sure to -- build your application in such a way, that it -- anticipates failure.- receive :: MonadUnliftIO m => msgBox a -> m (Maybe a)+ receive :: MonadUnliftIO m => box a -> m (Maybe a) -- | Return a 'Future' that can be used to wait for the -- arrival of the next message. -- NOTE: Each future value represents the next slot in the queue -- so one future corresponds to exactly that message (should it arrive) -- and if that future value is dropped, that message will be lost!- tryReceive :: MonadUnliftIO m => msgBox a -> m (Future a)+ tryReceive :: MonadUnliftIO m => box a -> m (Future a) -- | Wait for an incoming message or return Nothing. --@@ -77,7 +82,7 @@ receiveAfter :: MonadUnliftIO m => -- | Message box- msgBox a ->+ box a -> -- | Time in micro seconds to wait until the -- action is invoked. Int ->@@ -86,8 +91,8 @@ tryReceive mbox >>= timeout t . awaitFuture -- | Create a new @input@ that enqueus messages,- -- which are received by the @msgBox@- newInput :: MonadUnliftIO m => msgBox a -> m (Input msgBox a)+ -- which are received by the @box@+ newInput :: MonadUnliftIO m => box a -> m (Input box a) -- | A type class for input types. -- A common interface for delivering messages.@@ -102,17 +107,21 @@ -- build your application in such a way, that it -- anticipates failure. deliver :: MonadUnliftIO m => input a -> a -> m Bool+ -- | See 'deliver' but with @()@ as return value.+ -- If 'deliver' fails, it fails silently.+ deliver_ :: MonadUnliftIO m => input a -> a -> m ()+ deliver_ i a = void (deliver i a) -- ** Utility Functions for Receiving Messages -- | Receive a message and apply a function to it. handleMessage ::- (MonadUnliftIO m, IsMessageBox msgBox) =>- msgBox message ->+ (MonadUnliftIO m, IsMessageBox box) =>+ box message -> (message -> m b) -> m (Maybe b)-handleMessage !msgBox !onMessage = do- !maybeMessage <- receive msgBox+handleMessage !box !onMessage = do+ !maybeMessage <- receive box case maybeMessage of Nothing -> pure Nothing Just !message -> do
src/UnliftIO/MessageBox/Limited.hs view
@@ -84,7 +84,7 @@ MessageLimit_2048 -> 2048 MessageLimit_4096 -> 4096 --- * 'Class.IsMessageBoxFactory' instances+-- * 'Class.IsMessageBoxArg' instances -- ** Blocking @@ -116,7 +116,7 @@ -- The 'Input' is the counter part of a 'BlockingBox'. newtype BlockingInput a = MkBlockingInput (Unagi.InChan a) -instance Class.IsMessageBoxFactory BlockingBoxLimit where+instance Class.IsMessageBoxArg BlockingBoxLimit where type MessageBox BlockingBoxLimit = BlockingBox {-# INLINE newMessageBox #-} newMessageBox (BlockingBoxLimit !limit) = create limit@@ -148,7 +148,7 @@ -- ** A wrapper around 'BlockingBox' for Non-Blocking Input (NBI) --- | A 'BlockingBoxLimit' wrapper for non-blocking 'Class.IsMessageBoxFactory' instances.+-- | A 'BlockingBoxLimit' wrapper for non-blocking 'Class.IsMessageBoxArg' instances. newtype NonBlockingBoxLimit = NonBlockingBoxLimit MessageLimit deriving stock (Eq, Ord) @@ -156,7 +156,7 @@ showsPrec _ (NonBlockingBoxLimit !l) = showString "NonBlocking" . showsPrec 9 (messageLimitToInt l) -instance Class.IsMessageBoxFactory NonBlockingBoxLimit where+instance Class.IsMessageBoxArg NonBlockingBoxLimit where type MessageBox NonBlockingBoxLimit = NonBlockingBox {-# INLINE newMessageBox #-} newMessageBox (NonBlockingBoxLimit !l) =@@ -198,7 +198,7 @@ -- ** 'BlockingBox' Wrapper with Timeout --- | A 'Class.IsMessageBoxFactory' instance wrapping the 'BlockingBox'+-- | A 'Class.IsMessageBoxArg' instance wrapping the 'BlockingBox' -- with independently configurable timeouts for 'receive' and 'deliver'. data WaitingBoxLimit = WaitingBoxLimit@@ -218,7 +218,7 @@ . showChar '_' . showsPrec 9 (messageLimitToInt l) -instance Class.IsMessageBoxFactory WaitingBoxLimit where+instance Class.IsMessageBoxArg WaitingBoxLimit where type MessageBox WaitingBoxLimit = WaitingBox {-# INLINE newMessageBox #-} newMessageBox l@(WaitingBoxLimit _ _ !c) =
src/UnliftIO/MessageBox/Unlimited.hs view
@@ -48,13 +48,13 @@ newtype UnlimitedBoxInput a = MkUnlimitedBoxInput (Unagi.InChan a) -- | The (empty) configuration for creating--- 'UnlimitedBox'es using the 'Class.IsMessageBoxFactory' methods.+-- 'UnlimitedBox'es using the 'Class.IsMessageBoxArg' methods. data BlockingUnlimited = BlockingUnlimited instance Show BlockingUnlimited where showsPrec _ _ = showString "Unlimited" -instance Class.IsMessageBoxFactory BlockingUnlimited where+instance Class.IsMessageBoxArg BlockingUnlimited where type MessageBox BlockingUnlimited = UnlimitedBox {-# INLINE newMessageBox #-} newMessageBox BlockingUnlimited = create
unliftio-messagebox.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: unliftio-messagebox-version: 1.0.2+version: 2.0.0 description: Please see the README on GitHub at <https://github.com/sheyll/unliftio-messagebox#readme> synopsis: Fast and robust message queues for concurrent processes homepage: https://github.com/sheyll/unliftio-messagebox#readme@@ -8,7 +8,7 @@ author: Sven Heyll maintainer: sven.heyll@gmail.com category: Concurrency-tested-with: GHC==8.10.2,GHC==8.10.3+tested-with: GHC==8.10.2,GHC==8.10.3,GHC==8.10.4 copyright: Copyright Sven Heyll license: BSD-2-Clause license-file: LICENSE@@ -27,14 +27,6 @@ default: False manual: True -common executable-flags- ghc-options:- -threaded- "-with-rtsopts=-T -N -qa"- if flag(development)- ghc-prof-options: - "-with-rtsopts=-T -xt -xc -Pa -hc -L256"- common compiler-flags ghc-options: -Wall@@ -47,10 +39,10 @@ -Wpartial-fields -Wmissing-deriving-strategies -funbox-strict-fields- -Wno-missing-signatures + -Wno-missing-signatures+ -fno-full-laziness if flag(development) ghc-options:- -O2 -Werror ghc-prof-options: -fprof-auto @@ -111,7 +103,16 @@ UnboxedTuples, UndecidableInstances, UnliftedFFITypes- ++common executable-flags+ ghc-options:+ -threaded+ -rtsopts+ "-with-rtsopts=-T -N -qa"+ if flag(development)+ ghc-prof-options: + "-with-rtsopts=-T -xt -xc -Pa -hc -L256"+ common deps build-depends: atomic-primops,@@ -148,16 +149,7 @@ other-modules: MediaBenchmark hs-source-dirs: src-memleak-test - ghc-options:- -O2- -threaded- -rtsopts- "-with-rtsopts=-T -N" ghc-prof-options: - -O2- -threaded- -rtsopts- -fprof-auto "-with-rtsopts=-T -hy -pa -L256 -xt -N" build-depends: unliftio-messagebox