context 0.1.1.1 → 0.2.0.0
raw patch · 9 files changed
+246/−94 lines, 9 filesdep +exceptionsPVP ok
version bump matches the API change (PVP)
Dependencies added: exceptions
API changes (from Hackage documentation)
+ Context: withAdjusted :: forall m ctx a. (MonadIO m, MonadMask m) => Store ctx -> (ctx -> ctx) -> (ctx -> m a) -> m a
+ Context.Implicit: withAdjusted :: forall m ctx a. (MonadIO m, MonadMask m, ?contextStore :: Store ctx) => (ctx -> ctx) -> (ctx -> m a) -> m a
- Context: adjust :: Store ctx -> (ctx -> ctx) -> IO a -> IO a
+ Context: adjust :: forall m ctx a. (MonadIO m, MonadMask m) => Store ctx -> (ctx -> ctx) -> m a -> m a
- Context: mine :: Store ctx -> IO ctx
+ Context: mine :: forall m ctx. (MonadIO m, MonadThrow m) => Store ctx -> m ctx
- Context: mineMay :: Store ctx -> IO (Maybe ctx)
+ Context: mineMay :: forall m ctx. MonadIO m => Store ctx -> m (Maybe ctx)
- Context: mines :: Store ctx -> (ctx -> a) -> IO a
+ Context: mines :: forall m ctx a. (MonadIO m, MonadThrow m) => Store ctx -> (ctx -> a) -> m a
- Context: minesMay :: Store ctx -> (ctx -> a) -> IO (Maybe a)
+ Context: minesMay :: forall m ctx a. MonadIO m => Store ctx -> (ctx -> a) -> m (Maybe a)
- Context: use :: Store ctx -> ctx -> IO a -> IO a
+ Context: use :: forall m ctx a. (MonadIO m, MonadMask m) => Store ctx -> ctx -> m a -> m a
- Context: withEmptyStore :: (Store ctx -> IO a) -> IO a
+ Context: withEmptyStore :: forall m ctx a. (MonadIO m, MonadMask m) => (Store ctx -> m a) -> m a
- Context: withNonEmptyStore :: ctx -> (Store ctx -> IO a) -> IO a
+ Context: withNonEmptyStore :: forall m ctx a. (MonadIO m, MonadMask m) => ctx -> (Store ctx -> m a) -> m a
- Context.Implicit: adjust :: ?contextStore :: Store ctx => (ctx -> ctx) -> IO a -> IO a
+ Context.Implicit: adjust :: forall m ctx a. (MonadIO m, MonadMask m, ?contextStore :: Store ctx) => (ctx -> ctx) -> m a -> m a
- Context.Implicit: mine :: ?contextStore :: Store ctx => IO ctx
+ Context.Implicit: mine :: forall m ctx. (MonadIO m, MonadThrow m, ?contextStore :: Store ctx) => m ctx
- Context.Implicit: mineMay :: ?contextStore :: Store ctx => IO (Maybe ctx)
+ Context.Implicit: mineMay :: forall m ctx. (MonadIO m, ?contextStore :: Store ctx) => m (Maybe ctx)
- Context.Implicit: mines :: ?contextStore :: Store ctx => (ctx -> a) -> IO a
+ Context.Implicit: mines :: forall m ctx a. (MonadIO m, MonadThrow m, ?contextStore :: Store ctx) => (ctx -> a) -> m a
- Context.Implicit: minesMay :: ?contextStore :: Store ctx => (ctx -> a) -> IO (Maybe a)
+ Context.Implicit: minesMay :: forall m ctx a. (MonadIO m, ?contextStore :: Store ctx) => (ctx -> a) -> m (Maybe a)
- Context.Implicit: use :: ?contextStore :: Store ctx => ctx -> IO a -> IO a
+ Context.Implicit: use :: forall m ctx a. (MonadIO m, MonadMask m, ?contextStore :: Store ctx) => ctx -> m a -> m a
- Context.Implicit: withEmptyStore :: (Store ctx -> IO a) -> IO a
+ Context.Implicit: withEmptyStore :: forall m ctx a. (MonadIO m, MonadMask m) => (Store ctx -> m a) -> m a
- Context.Implicit: withNonEmptyStore :: ctx -> (Store ctx -> IO a) -> IO a
+ Context.Implicit: withNonEmptyStore :: forall m ctx a. (MonadIO m, MonadMask m) => ctx -> (Store ctx -> m a) -> m a
- Context.Internal: mineMay :: Store ctx -> IO (Maybe ctx)
+ Context.Internal: mineMay :: forall m ctx. MonadIO m => Store ctx -> m (Maybe ctx)
- Context.Internal: mineMayOnDefault :: (Maybe ctx -> Maybe ctx) -> Store ctx -> IO (Maybe ctx)
+ Context.Internal: mineMayOnDefault :: forall m ctx. MonadIO m => (Maybe ctx -> Maybe ctx) -> Store ctx -> m (Maybe ctx)
- Context.Internal: newStore :: PropagationStrategy -> Maybe ctx -> IO (Store ctx)
+ Context.Internal: newStore :: forall m ctx. MonadIO m => PropagationStrategy -> Maybe ctx -> m (Store ctx)
- Context.Internal: setDefault :: Store ctx -> ctx -> IO ()
+ Context.Internal: setDefault :: forall m ctx. MonadIO m => Store ctx -> ctx -> m ()
- Context.Internal: throwContextNotFound :: IO a
+ Context.Internal: throwContextNotFound :: forall m a. (MonadIO m, MonadThrow m) => m a
- Context.Internal: use :: Store ctx -> ctx -> IO a -> IO a
+ Context.Internal: use :: forall m ctx a. (MonadIO m, MonadMask m) => Store ctx -> ctx -> m a -> m a
- Context.Internal: view :: View ctx -> IO ctx
+ Context.Internal: view :: (MonadIO m, MonadThrow m) => View ctx -> m ctx
- Context.Internal: viewMay :: View ctx -> IO (Maybe ctx)
+ Context.Internal: viewMay :: MonadIO m => View ctx -> m (Maybe ctx)
- Context.Internal: withStore :: PropagationStrategy -> Maybe ctx -> (Store ctx -> IO a) -> IO a
+ Context.Internal: withStore :: forall m ctx a. (MonadIO m, MonadMask m) => PropagationStrategy -> Maybe ctx -> (Store ctx -> m a) -> m a
- Context.Storage: newStore :: PropagationStrategy -> Maybe ctx -> IO (Store ctx)
+ Context.Storage: newStore :: forall m ctx. MonadIO m => PropagationStrategy -> Maybe ctx -> m (Store ctx)
- Context.Storage: setDefault :: Store ctx -> ctx -> IO ()
+ Context.Storage: setDefault :: forall m ctx. MonadIO m => Store ctx -> ctx -> m ()
- Context.Storage: withStore :: PropagationStrategy -> Maybe ctx -> (Store ctx -> IO a) -> IO a
+ Context.Storage: withStore :: forall m ctx a. (MonadIO m, MonadMask m) => PropagationStrategy -> Maybe ctx -> (Store ctx -> m a) -> m a
- Context.View: view :: View ctx -> IO ctx
+ Context.View: view :: (MonadIO m, MonadThrow m) => View ctx -> m ctx
- Context.View: viewMay :: View ctx -> IO (Maybe ctx)
+ Context.View: viewMay :: MonadIO m => View ctx -> m (Maybe ctx)
Files
- CHANGELOG.md +12/−1
- README.md +0/−2
- context.cabal +3/−4
- library/Context.hs +64/−8
- library/Context/Implicit.hs +63/−7
- library/Context/Internal.hs +55/−24
- package.yaml +2/−1
- test-suite/Test/Context/ConcurrentSpec.hs +18/−18
- test-suite/Test/ContextSpec.hs +29/−29
CHANGELOG.md view
@@ -1,5 +1,16 @@ # Change log +## 0.2.0.0++* Lift signatures from `IO` to `MonadIO`, `MonadThrow` and `MonadMask`+* Type parameter order is now explicit via `ScopedTypeVariables`+* Add `withAdjusted` convenience function+* Re-export `Context.View` module from `Context.Implicit`++## 0.1.1.1++* Correct Haddocks+ ## 0.1.1.0 * Add `Context.View` module, which includes the `View` type + `view`, `viewMay`,@@ -8,4 +19,4 @@ ## 0.1.0.0 -Initial release+* Initial release
README.md view
@@ -2,8 +2,6 @@ [![Version badge][]][version] -🚧 This README is under construction and could use some love. 🚧- `context` provides thread-indexed storage around arbitrary context values. The interface supports nesting context values per thread, and at any point, the calling thread may ask for their current context.
context.cabal view
@@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: 0a180699622cead385416ab9074b2b14a3483e2654062eeccb05d9d4e894efbe name: context-version: 0.1.1.1+version: 0.2.0.0 synopsis: Thread-indexed, nested contexts description: Thread-indexed storage around arbitrary context values. The interface supports nesting context values per thread, and at any point, the calling thread may@@ -47,6 +45,7 @@ build-depends: base >=4.12 && <5 , containers >=0.6.0.1 && <0.7+ , exceptions >=0.10.0 && <0.11 default-language: Haskell2010 test-suite context-test-suite
library/Context.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-} module Context ( -- * Introduction@@ -13,6 +14,7 @@ -- ** Registering context , use , adjust+ , withAdjusted -- ** Asking for context , mine@@ -39,6 +41,8 @@ import Context.Storage import Context.View import Control.Monad ((<=<))+import Control.Monad.Catch (MonadMask, MonadThrow)+import Control.Monad.IO.Class (MonadIO) import Prelude import qualified Context.Internal as Internal @@ -48,7 +52,12 @@ -- to a non-empty 'Store'. -- -- @since 0.1.0.0-withNonEmptyStore :: ctx -> (Store ctx -> IO a) -> IO a+withNonEmptyStore+ :: forall m ctx a+ . (MonadIO m, MonadMask m)+ => ctx+ -> (Store ctx -> m a)+ -> m a withNonEmptyStore = Internal.withStore defaultPropagation . Just -- | Provides a new, empty 'Store'. 'mine', 'mines', and 'adjust' will throw@@ -56,7 +65,11 @@ -- when the 'Store' will contain context values that are always thread-specific. -- -- @since 0.1.0.0-withEmptyStore :: (Store ctx -> IO a) -> IO a+withEmptyStore+ :: forall m ctx a+ . (MonadIO m, MonadMask m)+ => (Store ctx -> m a)+ -> m a withEmptyStore = Internal.withStore defaultPropagation Nothing -- | Adjust the calling thread's context in the specified 'Store' for the@@ -64,17 +77,50 @@ -- calling thread has no registered context. -- -- @since 0.1.0.0-adjust :: Store ctx -> (ctx -> ctx) -> IO a -> IO a-adjust store f action = do+adjust+ :: forall m ctx a+ . (MonadIO m, MonadMask m)+ => Store ctx+ -> (ctx -> ctx)+ -> m a+ -> m a+adjust store f action = withAdjusted store f $ const action++-- | Convenience function to 'adjust' the context then supply the adjusted+-- context to the inner action. This function is equivalent to calling 'adjust'+-- and then immediately calling 'mine' in the inner action of 'adjust', e.g.:+--+-- > doStuff :: Store Thing -> (Thing -> Thing) -> IO ()+-- > doStuff store f = do+-- > adjust store f do+-- > adjustedThing <- mine store+-- > ...+--+-- Throws a 'NotFoundException' when the calling thread has no registered+-- context.+--+-- @since 0.2.0.0+withAdjusted+ :: forall m ctx a+ . (MonadIO m, MonadMask m)+ => Store ctx+ -> (ctx -> ctx)+ -> (ctx -> m a)+ -> m a+withAdjusted store f action = do adjustedContext <- mines store f- use store adjustedContext action+ use store adjustedContext $ action adjustedContext -- | Provide the calling thread its current context from the specified -- 'Store'. Throws a 'NotFoundException' when the calling thread has no -- registered context. -- -- @since 0.1.0.0-mine :: Store ctx -> IO ctx+mine+ :: forall m ctx+ . (MonadIO m, MonadThrow m)+ => Store ctx+ -> m ctx mine = maybe Internal.throwContextNotFound pure <=< mineMay -- | Provide the calling thread a selection from its current context in the@@ -82,14 +128,24 @@ -- thread has no registered context. -- -- @since 0.1.0.0-mines :: Store ctx -> (ctx -> a) -> IO a+mines+ :: forall m ctx a+ . (MonadIO m, MonadThrow m)+ => Store ctx+ -> (ctx -> a)+ -> m a mines store = maybe Internal.throwContextNotFound pure <=< minesMay store -- | Provide the calling thread a selection from its current context in the -- specified 'Store', if present. -- -- @since 0.1.0.0-minesMay :: Store ctx -> (ctx -> a) -> IO (Maybe a)+minesMay+ :: forall m ctx a+ . (MonadIO m)+ => Store ctx+ -> (ctx -> a)+ -> m (Maybe a) minesMay store selector = fmap (fmap selector) $ mineMay store -- $intro
library/Context/Implicit.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE ImplicitParams #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-} module Context.Implicit ( -- * Introduction@@ -14,6 +15,7 @@ -- ** Registering context , use , adjust+ , withAdjusted -- ** Asking for context , mine@@ -22,6 +24,9 @@ , mineMay , minesMay + -- * Views+ , module Context.View+ -- * Exceptions , NotFoundException(NotFoundException, threadId) @@ -32,9 +37,14 @@ , module Context.Storage ) where -import Context (NotFoundException(NotFoundException, threadId), Store, withEmptyStore, withNonEmptyStore)+import Context+ ( NotFoundException(NotFoundException, threadId), Store, withEmptyStore, withNonEmptyStore+ ) import Context.Concurrent import Context.Storage+import Context.View+import Control.Monad.Catch (MonadMask, MonadThrow)+import Control.Monad.IO.Class (MonadIO) import Prelude import qualified Context @@ -42,7 +52,12 @@ -- thread, for the duration of the specified action. -- -- @since 0.1.0.0-use :: (?contextStore :: Store ctx) => ctx -> IO a -> IO a+use+ :: forall m ctx a+ . (MonadIO m, MonadMask m, ?contextStore :: Store ctx)+ => ctx+ -> m a+ -> m a use = Context.use ?contextStore -- | Adjust the calling thread's context in the implicit 'Store' for the@@ -50,15 +65,45 @@ -- calling thread has no registered context. -- -- @since 0.1.0.0-adjust :: (?contextStore :: Store ctx) => (ctx -> ctx) -> IO a -> IO a+adjust+ :: forall m ctx a+ . (MonadIO m, MonadMask m, ?contextStore :: Store ctx)+ => (ctx -> ctx)+ -> m a+ -> m a adjust = Context.adjust ?contextStore +-- | Convenience function to 'adjust' the context then supply the adjusted+-- context to the inner action. This function is equivalent to calling 'adjust'+-- and then immediately calling 'mine' in the inner action of 'adjust', e.g.:+--+-- > doStuff :: Store Thing -> (Thing -> Thing) -> IO ()+-- > doStuff store f = do+-- > adjust store f do+-- > adjustedThing <- mine store+-- > ...+--+-- Throws a 'NotFoundException' when the calling thread has no registered+-- context.+--+-- @since 0.2.0.0+withAdjusted+ :: forall m ctx a+ . (MonadIO m, MonadMask m, ?contextStore :: Store ctx)+ => (ctx -> ctx)+ -> (ctx -> m a)+ -> m a+withAdjusted = Context.withAdjusted ?contextStore+ -- | Provide the calling thread its current context from the implicit -- 'Store'. Throws a 'NotFoundException' when the calling thread has no -- registered context. -- -- @since 0.1.0.0-mine :: (?contextStore :: Store ctx) => IO ctx+mine+ :: forall m ctx+ . (MonadIO m, MonadThrow m, ?contextStore :: Store ctx)+ => m ctx mine = Context.mine ?contextStore -- | Provide the calling thread a selection from its current context in the@@ -66,21 +111,32 @@ -- thread has no registered context. -- -- @since 0.1.0.0-mines :: (?contextStore :: Store ctx) => (ctx -> a) -> IO a+mines+ :: forall m ctx a+ . (MonadIO m, MonadThrow m, ?contextStore :: Store ctx)+ => (ctx -> a)+ -> m a mines = Context.mines ?contextStore -- | Provide the calling thread its current context from the implicit -- 'Store', if present. -- -- @since 0.1.0.0-mineMay :: (?contextStore :: Store ctx) => IO (Maybe ctx)+mineMay+ :: forall m ctx+ . (MonadIO m, ?contextStore :: Store ctx)+ => m (Maybe ctx) mineMay = Context.mineMay ?contextStore -- | Provide the calling thread a selection from its current context in the -- implicit 'Store', if present. -- -- @since 0.1.0.0-minesMay :: (?contextStore :: Store ctx) => (ctx -> a) -> IO (Maybe a)+minesMay+ :: forall m ctx a+ . (MonadIO m, ?contextStore :: Store ctx)+ => (ctx -> a)+ -> m (Maybe a) minesMay = Context.minesMay ?contextStore -- $intro
library/Context/Internal.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StrictData #-} module Context.Internal@@ -52,6 +53,8 @@ import Control.Concurrent (ThreadId) import Control.Exception (Exception) import Control.Monad ((<=<))+import Control.Monad.Catch (MonadMask, MonadThrow)+import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.IORef (IORef) import Data.Map.Strict (Map) import Data.Unique (Unique)@@ -60,7 +63,7 @@ import Prelude import System.IO.Unsafe (unsafePerformIO) import qualified Control.Concurrent as Concurrent-import qualified Control.Exception as Exception+import qualified Control.Monad.Catch as Catch import qualified Data.IORef as IORef import qualified Data.Map.Strict as Map import qualified Data.Traversable as Traversable@@ -118,27 +121,44 @@ -- > -- ... -- -- @since 0.1.0.0-setDefault :: Store ctx -> ctx -> IO ()+setDefault+ :: forall m ctx+ . (MonadIO m)+ => Store ctx+ -> ctx+ -> m () setDefault Store { ref } context = do- IORef.atomicModifyIORef' ref \state ->+ liftIO $ IORef.atomicModifyIORef' ref \state -> (state { def = Just context }, ()) -throwContextNotFound :: IO a+throwContextNotFound+ :: forall m a+ . (MonadIO m, MonadThrow m)+ => m a throwContextNotFound = do- threadId <- Concurrent.myThreadId- Exception.throwIO $ NotFoundException { threadId }+ threadId <- liftIO $ Concurrent.myThreadId+ Catch.throwM $ NotFoundException { threadId } -- | Provide the calling thread its current context from the specified -- 'Store', if present. -- -- @since 0.1.0.0-mineMay :: Store ctx -> IO (Maybe ctx)+mineMay+ :: forall m ctx+ . (MonadIO m)+ => Store ctx+ -> m (Maybe ctx) mineMay = mineMayOnDefault id -mineMayOnDefault :: (Maybe ctx -> Maybe ctx) -> Store ctx -> IO (Maybe ctx)+mineMayOnDefault+ :: forall m ctx+ . (MonadIO m)+ => (Maybe ctx -> Maybe ctx)+ -> Store ctx+ -> m (Maybe ctx) mineMayOnDefault onDefault Store { ref } = do- threadId <- Concurrent.myThreadId- State { stacks, def } <- IORef.readIORef ref+ threadId <- liftIO $ Concurrent.myThreadId+ State { stacks, def } <- liftIO $ IORef.readIORef ref pure case Map.lookup threadId stacks of Nothing -> onDefault def@@ -149,8 +169,15 @@ -- thread, for the duration of the specified action. -- -- @since 0.1.0.0-use :: Store ctx -> ctx -> IO a -> IO a-use store context = Exception.bracket_ (push store context) (pop store)+use+ :: forall m ctx a+ . (MonadIO m, MonadMask m)+ => Store ctx+ -> ctx+ -> m a+ -> m a+use store context =+ Catch.bracket_ (liftIO $ push store context) (liftIO $ pop store) -- | Provides a new 'Store'. This is a lower-level function and is provided -- mainly to give library authors more fine-grained control when using a 'Store'@@ -161,7 +188,9 @@ -- -- @since 0.1.0.0 withStore- :: PropagationStrategy+ :: forall m ctx a+ . (MonadIO m, MonadMask m)+ => PropagationStrategy -- ^ The strategy used by "Context.Concurrent" for propagating context from a -- "parent" thread to a new thread. -> Maybe ctx@@ -175,14 +204,14 @@ -- 'Context.mines', and 'Context.adjust' will throw 'Context.NotFoundException' when the calling -- thread has no registered context. Providing 'Nothing' is useful when the -- 'Store' will contain context values that are always thread-specific.- -> (Store ctx -> IO a)- -> IO a+ -> (Store ctx -> m a)+ -> m a withStore propagationStrategy mContext f = do store <- newStore propagationStrategy mContext- Exception.finally (f store) do+ Catch.finally (f store) do case propagationStrategy of NoPropagation -> pure ()- LatestPropagation -> unregister registry store+ LatestPropagation -> liftIO $ unregister registry store -- | Creates a new 'Store'. This is a lower-level function and is provided -- /only/ to support the use case of creating a 'Store' as a global:@@ -198,7 +227,9 @@ -- -- @since 0.1.0.0 newStore- :: PropagationStrategy+ :: forall m ctx+ . (MonadIO m)+ => PropagationStrategy -- ^ The strategy used by "Context.Concurrent" for propagating context from a -- "parent" thread to a new thread. -> Maybe ctx@@ -212,14 +243,14 @@ -- 'Context.mines', and 'Context.adjust' will throw 'Context.NotFoundException' when the calling -- thread has no registered context. Providing 'Nothing' is useful when the -- 'Store' will contain context values that are always thread-specific.- -> IO (Store ctx)+ -> m (Store ctx) newStore propagationStrategy def = do- key <- Unique.newUnique- ref <- IORef.newIORef State { stacks = Map.empty, def }+ key <- liftIO $ Unique.newUnique+ ref <- liftIO $ IORef.newIORef State { stacks = Map.empty, def } let store = Store { ref, key } case propagationStrategy of NoPropagation -> pure ()- LatestPropagation -> register registry store+ LatestPropagation -> liftIO $ register registry store pure store push :: Store ctx -> ctx -> IO ()@@ -262,14 +293,14 @@ -- thread has no registered context. -- -- @since 0.1.1.0-view :: View ctx -> IO ctx+view :: (MonadIO m, MonadThrow m) => View ctx -> m ctx view = maybe throwContextNotFound pure <=< viewMay -- | Provide the calling thread a view of its current context from the specified -- 'Context.View.View', if present. -- -- @since 0.1.1.0-viewMay :: View ctx -> IO (Maybe ctx)+viewMay :: (MonadIO m) => View ctx -> m (Maybe ctx) viewMay = \case MkView f store -> fmap (fmap f) $ mineMay store
package.yaml view
@@ -1,5 +1,5 @@ name: context-version: '0.1.1.1'+version: '0.2.0.0' github: "jship/context" license: MIT license-file: LICENSE.md@@ -29,6 +29,7 @@ dependencies: - base >=4.12 && <5 - containers >=0.6.0.1 && <0.7+ - exceptions >=0.10.0 && <0.11 source-dirs: library tests:
test-suite/Test/Context/ConcurrentSpec.hs view
@@ -23,8 +23,8 @@ describe "mineMay" do it "empty stores" do threadDone <- Context.newEmptyMVar- Context.withEmptyStore @Thing \store1 -> do- Context.withEmptyStore @Char \store2 -> do+ Context.withEmptyStore @IO @Thing \store1 -> do+ Context.withEmptyStore @IO @Char \store2 -> do Monad.void $ Context.forkIO do Context.mineMay store1 `shouldReturn` Nothing Context.mineMay store2 `shouldReturn` Nothing@@ -68,8 +68,8 @@ describe "mineMay" do it "empty stores" do threadDone <- Context.newEmptyMVar- Context.withEmptyStore @Thing \store1 -> do- Context.withEmptyStore @Char \store2 -> do+ Context.withEmptyStore @IO @Thing \store1 -> do+ Context.withEmptyStore @IO @Char \store2 -> do let checkStores = do Context.mineMay store1 `shouldReturn` Nothing Context.mineMay store2 `shouldReturn` Nothing@@ -121,8 +121,8 @@ describe "mineMay" do it "empty stores" do threadDone <- Context.newEmptyMVar- Context.withEmptyStore @Thing \store1 -> do- Context.withEmptyStore @Char \store2 -> do+ Context.withEmptyStore @IO @Thing \store1 -> do+ Context.withEmptyStore @IO @Char \store2 -> do Monad.void $ Context.forkIOWithUnmask \_restore -> do Context.mineMay store1 `shouldReturn` Nothing Context.mineMay store2 `shouldReturn` Nothing@@ -166,8 +166,8 @@ describe "mineMay" do it "empty stores" do threadDone <- Context.newEmptyMVar- Context.withEmptyStore @Thing \store1 -> do- Context.withEmptyStore @Char \store2 -> do+ Context.withEmptyStore @IO @Thing \store1 -> do+ Context.withEmptyStore @IO @Char \store2 -> do Monad.void $ Context.forkOn 1 do Context.mineMay store1 `shouldReturn` Nothing Context.mineMay store2 `shouldReturn` Nothing@@ -211,8 +211,8 @@ describe "mineMay" do it "empty stores" do threadDone <- Context.newEmptyMVar- Context.withEmptyStore @Thing \store1 -> do- Context.withEmptyStore @Char \store2 -> do+ Context.withEmptyStore @IO @Thing \store1 -> do+ Context.withEmptyStore @IO @Char \store2 -> do Monad.void $ Context.forkOnWithUnmask 1 \_restore -> do Context.mineMay store1 `shouldReturn` Nothing Context.mineMay store2 `shouldReturn` Nothing@@ -256,8 +256,8 @@ describe "mineMay" do it "empty stores" do threadDone <- Context.newEmptyMVar- Context.withEmptyStore @Thing \store1 -> do- Context.withEmptyStore @Char \store2 -> do+ Context.withEmptyStore @IO @Thing \store1 -> do+ Context.withEmptyStore @IO @Char \store2 -> do Monad.void $ Context.forkOS do Context.mineMay store1 `shouldReturn` Nothing Context.mineMay store2 `shouldReturn` Nothing@@ -301,8 +301,8 @@ describe "mineMay" do it "empty stores" do threadDone <- Context.newEmptyMVar- Context.withEmptyStore @Thing \store1 -> do- Context.withEmptyStore @Char \store2 -> do+ Context.withEmptyStore @IO @Thing \store1 -> do+ Context.withEmptyStore @IO @Char \store2 -> do Monad.void $ Context.forkOSWithUnmask \_restore -> do Context.mineMay store1 `shouldReturn` Nothing Context.mineMay store2 `shouldReturn` Nothing@@ -346,8 +346,8 @@ describe "mineMay" do it "empty stores" do threadDone <- Context.newEmptyMVar- Context.withEmptyStore @Thing \store1 -> do- Context.withEmptyStore @Char \store2 -> do+ Context.withEmptyStore @IO @Thing \store1 -> do+ Context.withEmptyStore @IO @Char \store2 -> do Context.runInBoundThread do Context.mineMay store1 `shouldReturn` Nothing Context.mineMay store2 `shouldReturn` Nothing@@ -391,8 +391,8 @@ describe "mineMay" do it "empty stores" do threadDone <- Context.newEmptyMVar- Context.withEmptyStore @Thing \store1 -> do- Context.withEmptyStore @Char \store2 -> do+ Context.withEmptyStore @IO @Thing \store1 -> do+ Context.withEmptyStore @IO @Char \store2 -> do Context.runInUnboundThread do Context.mineMay store1 `shouldReturn` Nothing Context.mineMay store2 `shouldReturn` Nothing
test-suite/Test/ContextSpec.hs view
@@ -28,15 +28,15 @@ describe "withEmptyStore" do describe "mineMay" do it "empty" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Context.mineMay store `shouldReturn` Nothing it "single context" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Context.use store Thing { stuff = 1 } do Context.mineMay store `shouldReturn` Just Thing { stuff = 1 } Context.mineMay store `shouldReturn` Nothing it "nested contexts" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Context.use store Thing { stuff = 1 } do Context.mineMay store `shouldReturn` Just Thing { stuff = 1 } Context.use store Thing { stuff = 2 } do@@ -50,7 +50,7 @@ Context.mineMay store `shouldReturn` Nothing it "concurrent nested contexts" do let mkContext i = Thing { stuff = i }- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Async.forConcurrently_ [1 :: Int ..10] $ const do Context.mineMay store `shouldReturn` Nothing Context.use store (mkContext 1) do@@ -68,15 +68,15 @@ describe "minesMay" do it "empty" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Context.minesMay store stuff `shouldReturn` Nothing it "single context" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Context.use store Thing { stuff = 1 } do Context.minesMay store stuff `shouldReturn` Just 1 Context.minesMay store stuff `shouldReturn` Nothing it "nested contexts" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Context.use store Thing { stuff = 1 } do Context.minesMay store stuff `shouldReturn` Just 1 Context.use store Thing { stuff = 2 } do@@ -90,7 +90,7 @@ Context.minesMay store stuff `shouldReturn` Nothing it "concurrent nested contexts" do let mkContext i = Thing { stuff = i }- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Async.forConcurrently_ [1 :: Int ..10] $ const do Context.minesMay store stuff `shouldReturn` Nothing Context.use store (mkContext 1) do@@ -108,17 +108,17 @@ describe "mine" do it "empty" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do threadId <- Concurrent.myThreadId Context.mine store `shouldThrow` notFound threadId it "single context" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do threadId <- Concurrent.myThreadId Context.use store Thing { stuff = 1 } do Context.mine store `shouldReturn` Thing { stuff = 1 } Context.mine store `shouldThrow` notFound threadId it "nested contexts" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do threadId <- Concurrent.myThreadId Context.use store Thing { stuff = 1 } do Context.mine store `shouldReturn` Thing { stuff = 1 }@@ -134,7 +134,7 @@ it "concurrent nested contexts" do let mkContext i = Thing { stuff = i } initThreadId <- Concurrent.myThreadId- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Async.forConcurrently_ [1 :: Int ..10] $ const do threadId <- Concurrent.myThreadId Context.mine store `shouldThrow` notFound threadId@@ -153,17 +153,17 @@ describe "mines" do it "empty" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do threadId <- Concurrent.myThreadId Context.mines store stuff `shouldThrow` notFound threadId it "single context" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do threadId <- Concurrent.myThreadId Context.use store Thing { stuff = 1 } do Context.mines store stuff `shouldReturn` 1 Context.mines store stuff `shouldThrow` notFound threadId it "nested contexts" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do threadId <- Concurrent.myThreadId Context.use store Thing { stuff = 1 } do Context.mines store stuff `shouldReturn` 1@@ -179,7 +179,7 @@ it "concurrent nested contexts" do let mkContext i = Thing { stuff = i } initThreadId <- Concurrent.myThreadId- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Async.forConcurrently_ [1 :: Int ..10] $ const do threadId <- Concurrent.myThreadId Context.mine store `shouldThrow` notFound threadId@@ -198,12 +198,12 @@ describe "adjust" do it "empty" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do threadId <- Concurrent.myThreadId Context.adjust store modifier (error "does not get here") `shouldThrow` notFound threadId it "single context" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do threadId <- Concurrent.myThreadId Context.use store Thing { stuff = 1 } do Context.mine store `shouldReturn` Thing { stuff = 1 }@@ -212,7 +212,7 @@ Context.mine store `shouldReturn` Thing { stuff = 1 } Context.mine store `shouldThrow` notFound threadId it "nested contexts" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do threadId <- Concurrent.myThreadId Context.use store Thing { stuff = 1 } do Context.adjust store modifier do@@ -230,7 +230,7 @@ it "concurrent nested contexts" do let mkContext i = Thing { stuff = i } initThreadId <- Concurrent.myThreadId- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Async.forConcurrently_ [1 :: Int ..10] $ const do threadId <- Concurrent.myThreadId Context.mine store `shouldThrow` notFound threadId@@ -251,7 +251,7 @@ describe "setDefault" do it "setting default converts store to non-empty" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do Context.mineMay store `shouldReturn` Nothing Context.setDefault store Thing { stuff = 1 } Context.mineMay store `shouldReturn` Just Thing { stuff = 1 }@@ -477,17 +477,17 @@ describe "viewMay" do it "empty" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do let storeView = fmap toOtherThing $ Context.toView store Context.viewMay storeView `shouldReturn` Nothing it "single context" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do let storeView = fmap toOtherThing $ Context.toView store Context.use store Thing { stuff = 1 } do Context.viewMay storeView `shouldReturn` Just OtherThing { otherStuff = 1 } Context.viewMay storeView `shouldReturn` Nothing it "nested contexts" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do let storeView = fmap toOtherThing $ Context.toView store Context.use store Thing { stuff = 1 } do Context.viewMay storeView `shouldReturn` Just OtherThing { otherStuff = 1 }@@ -502,7 +502,7 @@ Context.viewMay storeView `shouldReturn` Nothing it "concurrent nested contexts" do let mkContext i = Thing { stuff = i }- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do let storeView = fmap toOtherThing $ Context.toView store Async.forConcurrently_ [1 :: Int ..10] $ const do Context.viewMay storeView `shouldReturn` Nothing@@ -521,19 +521,19 @@ describe "view" do it "empty" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do let storeView = fmap toOtherThing $ Context.toView store threadId <- Concurrent.myThreadId Context.view storeView `shouldThrow` notFound threadId it "single context" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do let storeView = fmap toOtherThing $ Context.toView store threadId <- Concurrent.myThreadId Context.use store Thing { stuff = 1 } do Context.view storeView `shouldReturn` OtherThing { otherStuff = 1 } Context.view storeView `shouldThrow` notFound threadId it "nested contexts" do- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do let storeView = fmap toOtherThing $ Context.toView store threadId <- Concurrent.myThreadId Context.use store Thing { stuff = 1 } do@@ -550,7 +550,7 @@ it "concurrent nested contexts" do let mkContext i = Thing { stuff = i } initThreadId <- Concurrent.myThreadId- Context.withEmptyStore @Thing \store -> do+ Context.withEmptyStore @IO @Thing \store -> do let storeView = fmap toOtherThing $ Context.toView store Async.forConcurrently_ [1 :: Int ..10] $ const do threadId <- Concurrent.myThreadId