context (empty) → 0.1.0.0

raw patch · 14 files changed

+2113/−0 lines, 14 filesdep +asyncdep +basedep +containers

Dependencies added: async, base, containers, context, ghc-prim, hspec

Files

• CHANGELOG.md +5/−0
• LICENSE.md +23/−0
• README.md +36/−0
• context.cabal +70/−0
• library/Context.hs +138/−0
• library/Context/Concurrent.hs +151/−0
• library/Context/Implicit.hs +139/−0
• library/Context/Internal.hs +285/−0
• library/Context/Storage.hs +58/−0
• package.yaml +47/−0
• test-suite/Driver.hs +1/−0
• test-suite/Test/Context/ConcurrentSpec.hs +433/−0
• test-suite/Test/Context/ImplicitSpec.hs +248/−0
• test-suite/Test/ContextSpec.hs +479/−0

@@ -0,0 +1,5 @@+# Change log++## 0.1.0.0++Initial release

@@ -0,0 +1,23 @@+[The MIT License (MIT)][]++Copyright (c) 2020 Jason Shipman++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies+of the Software, and to permit persons to whom the Software is furnished to do+so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.++[The MIT License (MIT)]: https://opensource.org/licenses/MIT

@@ -0,0 +1,36 @@+# [context][]++[![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.++## Synopsis++```haskell+{-# LANGUAGE BlockArguments #-}++import qualified Context++data Thing = Thing+  { stuff :: Int+  }++main :: IO ()+main = do+  Context.withEmptyStore \store -> do+    Context.use store Thing { stuff = 1 } do+      Context.use store Thing { stuff = 2 } do+        thing2 <- Context.mine store+        -- ...+      number1 <- Context.mines store stuff+```++See the Haddocks for more info on the library.++[context]: https://github.com/jship/context/context+[Version badge]: https://img.shields.io/hackage/v/context?color=brightgreen&label=version&logo=haskell+[version]: https://hackage.haskell.org/package/context

@@ -0,0 +1,70 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: f039a0aad49f186ced980c33e32c16906b02598865a644fb1142fda2f631183d++name:           context+version:        0.1.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+                ask for their current context.+category:       Data+homepage:       https://github.com/jship/context#readme+bug-reports:    https://github.com/jship/context/issues+author:         Jason Shipman+maintainer:     Jason Shipman+copyright:      2020 (c) Jason Shipman+license:        MIT+license-file:   LICENSE.md+build-type:     Simple+extra-source-files:+    CHANGELOG.md+    LICENSE.md+    package.yaml+    README.md++source-repository head+  type: git+  location: https://github.com/jship/context++library+  exposed-modules:+      Context+      Context.Concurrent+      Context.Implicit+      Context.Internal+      Context.Storage+  other-modules:+      Paths_context+  hs-source-dirs:+      library+  ghc-options: -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wredundant-constraints+  build-depends:+      base >=4.12 && <5+    , containers >=0.6.0.1 && <0.7+  default-language: Haskell2010++test-suite context-test-suite+  type: exitcode-stdio-1.0+  main-is: Driver.hs+  other-modules:+      Test.Context.ConcurrentSpec+      Test.Context.ImplicitSpec+      Test.ContextSpec+      Paths_context+  hs-source-dirs:+      test-suite+  ghc-options: -Wall -fwarn-tabs -Wincomplete-uni-patterns -Wredundant-constraints -threaded+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      async+    , base+    , context+    , ghc-prim+    , hspec+  default-language: Haskell2010

@@ -0,0 +1,138 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StrictData #-}++module Context+  ( -- * Introduction+    -- $intro++    -- * Storage+    Store+  , withNonEmptyStore+  , withEmptyStore++    -- * Operations+    -- ** Registering context+  , use+  , adjust++    -- ** Asking for context+  , mine+  , mines++  , mineMay+  , minesMay++    -- * Exceptions+  , NotFoundException(NotFoundException, threadId)++    -- * Concurrency+  , module Context.Concurrent++    -- * Lower-level storage+  , module Context.Storage+  ) where++import Context.Concurrent+import Context.Internal (Store, mineMay, use)+import Context.Storage+import Control.Exception (Exception)+import Control.Monad ((<=<))+import GHC.Generics (Generic)+import Prelude+import qualified Context.Internal as Internal+import qualified Control.Exception as Exception++-- | An exception which may be thrown via 'mine', 'mines', and 'adjust' when the+-- calling thread does not have a registered context.+--+-- @since 0.1.0.0+data NotFoundException = NotFoundException+  { threadId :: ThreadId+  } deriving stock (Eq, Generic, Show)+    deriving anyclass Exception++-- | Provides a new, non-empty 'Store' that uses the specified context value as a+-- default when the calling thread has no registered context. 'mine', 'mines',+-- and 'adjust' are guaranteed to never throw 'NotFoundException' when applied+-- to a non-empty 'Store'.+--+-- @since 0.1.0.0+withNonEmptyStore :: ctx -> (Store ctx -> IO a) -> IO a+withNonEmptyStore = Internal.withStore defaultPropagation . Just++-- | Provides a new, empty 'Store'. 'mine', 'mines', and 'adjust' will throw+-- 'NotFoundException' when the calling thread has no registered context. Useful+-- 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 = Internal.withStore defaultPropagation Nothing++-- | Adjust the calling thread's context in the specified 'Store' for the+-- duration of the specified action. Throws a 'NotFoundException' when the+-- 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+  adjustedContext <- mines store f+  use store adjustedContext action++-- | 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 = maybe throwContextNotFound pure <=< mineMay++-- | Provide the calling thread a selection from its current context in the+-- specified 'Store'. Throws a 'NotFoundException' when the calling+-- thread has no registered context.+--+-- @since 0.1.0.0+mines :: Store ctx -> (ctx -> a) -> IO a+mines store = maybe 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 store selector = fmap (fmap selector) $ mineMay store++throwContextNotFound :: IO a+throwContextNotFound = do+  threadId <- myThreadId+  Exception.throwIO $ NotFoundException { threadId }++-- $intro+--+-- This module provides an opaque 'Store' for 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 its current context.+--+-- Note that threads in Haskell have no explicit parent-child relationship. So if+-- you register a context in a 'Store' produced by 'withEmptyStore', spin up a+-- separate thread, and from that thread you ask for a context, that thread will+-- not have a context in the 'Store'. Use "Context.Concurrent" as a drop-in+-- replacement for "Control.Concurrent" to have the library handle context+-- propagation from one thread to another automatically. Otherwise, you must+-- explicitly register contexts from each thread when using a 'Store' produced by+-- 'withEmptyStore'.+--+-- If you have a default context that is always applicable to all threads, you may+-- wish to use 'withNonEmptyStore'. All threads may access this default context+-- (without leveraging "Context.Concurrent" or explicitly registering context+-- for the threads) when using a 'Store' produced by 'withNonEmptyStore'.+--+-- Regardless of how you initialize your 'Store', every thread is free to nest its+-- own specific context values.+--+-- This module is designed to be imported qualified:+--+-- > import qualified Context

@@ -0,0 +1,151 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}++module Context.Concurrent+  ( -- * Introduction+    -- $intro++    -- * Control.Concurrent wrappers+    forkIO+  , forkFinally+  , forkIOWithUnmask+  , forkOn+  , forkOnWithUnmask+  , forkOS+  , forkOSWithUnmask+  , runInBoundThread+  , runInUnboundThread++    -- * Control.Concurrent re-exports+  , ThreadId+  , myThreadId+  , killThread+  , throwTo+  , getNumCapabilities+  , setNumCapabilities+  , threadCapability+  , yield+  , threadDelay+  , threadWaitRead+  , threadWaitWrite+  , threadWaitReadSTM+  , threadWaitWriteSTM+  , rtsSupportsBoundThreads+  , isCurrentThreadBound+  , mkWeakThreadId+  , module Control.Concurrent.MVar+  , module Control.Concurrent.Chan+  , module Control.Concurrent.QSem+  , module Control.Concurrent.QSemN+  ) where++import Control.Concurrent+  ( ThreadId, getNumCapabilities, isCurrentThreadBound, killThread, mkWeakThreadId, myThreadId+  , rtsSupportsBoundThreads, setNumCapabilities, threadCapability, threadDelay, threadWaitRead+  , threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, throwTo, yield+  )+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Concurrent.QSem+import Control.Concurrent.QSemN+import Control.Exception (SomeException)+import Prelude+import qualified Context.Internal as Internal+import qualified Control.Concurrent as Concurrent+import qualified Control.Exception as Exception++-- | See 'Concurrent.forkIO'.+--+-- @since 0.1.0.0+forkIO :: IO () -> IO ThreadId+forkIO action = do+  Internal.withPropagator \propagate -> do+    Concurrent.forkIO $ propagate action++-- | See 'Concurrent.forkFinally'.+--+-- @since 0.1.0.0+forkFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId+forkFinally action and_then = do+  -- N.B. We re-implement forkFinally instead of delegating directly to the+  -- Control.Concurrent function. This enables us to propagate context a single+  -- time to make it available to both the thread's main action and terminating+  -- action.+  Internal.withPropagator \propagate -> do+    Exception.mask \restore -> do+      Concurrent.forkIO $ propagate do+        Exception.try (restore action) >>= and_then++-- | See 'Concurrent.forkIOWithUnmask'.+--+-- @since 0.1.0.0+forkIOWithUnmask :: ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId+forkIOWithUnmask io = do+  Internal.withPropagator \propagate -> do+    Concurrent.forkIOWithUnmask \restore -> do+      propagate $ io restore++-- | See 'Concurrent.forkOn'.+--+-- @since 0.1.0.0+forkOn :: Int -> IO () -> IO ThreadId+forkOn cpu action = do+  Internal.withPropagator \propagate -> do+    Concurrent.forkOn cpu $ propagate action++-- | See 'Concurrent.forkOnWithUnmask'.+--+-- @since 0.1.0.0+forkOnWithUnmask :: Int -> ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId+forkOnWithUnmask cpu io = do+  Internal.withPropagator \propagate -> do+    Concurrent.forkOnWithUnmask cpu \restore -> do+      propagate $ io restore++-- | See 'Concurrent.forkOS'.+--+-- @since 0.1.0.0+forkOS :: IO () -> IO ThreadId+forkOS action = do+  Internal.withPropagator \propagate -> do+    Concurrent.forkOS $ propagate action++-- | See 'Concurrent.forkOSWithUnmask'.+--+-- @since 0.1.0.0+forkOSWithUnmask :: ((forall a. IO a -> IO a) -> IO ()) -> IO ThreadId+forkOSWithUnmask io = do+  Internal.withPropagator \propagate -> do+    Concurrent.forkOSWithUnmask \restore -> do+      propagate $ io restore++-- | See 'Concurrent.runInBoundThread'.+--+-- @since 0.1.0.0+runInBoundThread :: IO a -> IO a+runInBoundThread action =+  Internal.withPropagator \propagate -> do+    Concurrent.runInBoundThread $ propagate action++-- | See 'Concurrent.runInUnboundThread'.+--+-- @since 0.1.0.0+runInUnboundThread :: IO a -> IO a+runInUnboundThread action =+  Internal.withPropagator \propagate -> do+    Concurrent.runInUnboundThread $ propagate action++-- $intro+--+-- This module provides a "Context"-compatible interface around+-- "Control.Concurrent". Depending on the 'Context.Storage.PropagationStrategy'+-- of the 'Context.Store', the @fork*@ and @run*@ functions in this module can+-- automatically propagate the calling thread's latest registered contexts, if+-- any, over so that they are also available to the thread being created.+--+-- This module is designed to be a drop-in replacement for "Control.Concurrent" so+-- that users only have to import this module instead of both this module and+-- "Control.Concurrent". It is also re-exported from "Context" for convenience.

@@ -0,0 +1,139 @@+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Context.Implicit+  ( -- * Introduction+    -- $intro++    -- * Storage+    Store+  , withNonEmptyStore+  , withEmptyStore++    -- * Operations+    -- ** Registering context+  , use+  , adjust++    -- ** Asking for context+  , mine+  , mines++  , mineMay+  , minesMay++    -- * Exceptions+  , NotFoundException(NotFoundException, threadId)++    -- * Concurrency+  , module Context.Concurrent++    -- * Lower-level storage+  , module Context.Storage+  ) where++import Context (NotFoundException(NotFoundException, threadId), Store, withEmptyStore, withNonEmptyStore)+import Context.Concurrent+import Context.Storage+import Prelude+import qualified Context++-- | Register a context in the implicit 'Store' on behalf of the calling+-- thread, for the duration of the specified action.+--+-- @since 0.1.0.0+use :: (?contextStore :: Store ctx) => ctx -> IO a -> IO a+use = Context.use ?contextStore++-- | Adjust the calling thread's context in the implicit 'Store' for the+-- duration of the specified action. Throws a 'NotFoundException' when the+-- calling thread has no registered context.+--+-- @since 0.1.0.0+adjust :: (?contextStore :: Store ctx) => (ctx -> ctx) -> IO a -> IO a+adjust = Context.adjust ?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 = Context.mine ?contextStore++-- | Provide the calling thread a selection from its current context in the+-- implicit 'Store'. Throws a 'NotFoundException' when the calling+-- thread has no registered context.+--+-- @since 0.1.0.0+mines :: (?contextStore :: Store ctx) => (ctx -> a) -> IO 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 = 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 = Context.minesMay ?contextStore++-- $intro+--+-- This module provides the same interface provided by "Context", but uses an+-- implicit 'Store' where applicable. Usage of this module requires that the+-- implicit parameter is named @contextStore@ in calling code.+--+-- This module is designed to be imported qualified:+--+-- > import qualified Context.Implicit+--+-- If you are only working with an implicit 'Store' in your application, you may+-- prefer shortening the import name:+--+-- > import qualified Context.Implicit as Context+--+-- Usage of this module might look something like this:+--+-- > main :: IO ()+-- > main = do+-- >   let config = -- ...+-- >   withDependencies config \deps -> do+-- >     Context.withNonEmptyStore deps \depsStore -> do+-- >       let ?contextStore = depsStore+-- >       doStuff+-- >+-- > doStuff :: (?contextStore :: Store Dependencies) => IO ()+-- > doStuff = do+-- >   deps <- Context.mine+-- >   -- ...+--+-- If the application is using a 'Store' in a global variable, then this 'Store'+-- can be conveniently injected in for use with this module via a global+-- implicit parameter:+--+-- > module Dependencies where+-- >+-- > import qualified Context.Implicit as Context+-- > import GHC.Classes(IP(ip)) -- from 'ghc-prim' package+-- >+-- > data Dependencies = -- ...+-- >+-- > depsStore :: Store Dependencies+-- > depsStore = unsafePerformIO $ Context.newStore Context.defaultPropagation Nothing+-- > {-# NOINLINE depsStore #-}+-- >+-- > instance IP "contextStore" (Store Dependencies) where+-- >   ip = depsStore+--+-- With a global implicit parameter, the @(?contextStore :: Store Dependencies)@+-- constraint does not need to be threaded throughout the application's+-- signatures, but it still can be overridden within local scopes as needed.+--+-- For an intro to global implicit parameters, see this post:+-- <https://kcsongor.github.io/global-implicit-parameters/>

@@ -0,0 +1,285 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StrictData #-}++module Context.Internal+  ( -- * Disclaimer+    -- $disclaimer++    -- ** Store-related+    Store(Store, ref, key)+  , State(State, stacks, def)+  , withStore+  , newStore+  , use+  , push+  , pop+  , mineMay+  , mineMayOnDefault+  , setDefault++    -- ** Propagation-related+  , PropagationStrategy(NoPropagation, LatestPropagation)+  , Registry(Registry, ref)+  , AnyStore(MkAnyStore)+  , registry+  , emptyRegistry+  , withPropagator+  , withRegisteredPropagator+  , register+  , unregister++    -- ** Miscellaneous+  , bug+  ) where++import Control.Concurrent (ThreadId)+import Data.IORef (IORef)+import Data.Map.Strict (Map)+import Data.Unique (Unique)+import GHC.Stack (HasCallStack)+import Prelude+import System.IO.Unsafe (unsafePerformIO)+import qualified Control.Concurrent as Concurrent+import qualified Control.Exception as Exception+import qualified Data.IORef as IORef+import qualified Data.Map.Strict as Map+import qualified Data.Traversable as Traversable+import qualified Data.Unique as Unique++-- | Opaque type that manages thread-indexed storage of context values.+--+-- @since 0.1.0.0+data Store ctx = Store+  { ref :: IORef (State ctx)+  , key :: Unique+  }++data State ctx = State+  { stacks :: Map ThreadId [ctx]+  , def :: Maybe ctx+  }++-- | The 'PropagationStrategy' controls the behavior used by+-- "Context.Concurrent" when propagating context from a "parent" thread to a new+-- thread.+--+-- @since 0.1.0.0+data PropagationStrategy+  = NoPropagation+  | LatestPropagation++-- | Set the default context value for a store. If the store was initialized as+-- an empty store, this function converts it to a non-empty store. If the store+-- was initialized as a non-empty store, this overwrites the default context+-- value.+--+-- One common use case for this function is to convert an empty store in a+-- global variable to a non-empty store while the application is+-- initializing/acquiring resources:+--+-- > depsStore :: Store Dependencies+-- > depsStore = unsafePerformIO $ Context.newStore Context.defaultPropagation Nothing+-- > {-# NOINLINE depsStore #-}+-- >+-- > main :: IO ()+-- > main = do+-- >   let config = -- ...+-- >   withDependencies config \deps -> do+-- >     Context.setDefault depsStore deps+-- >     -- ...+--+-- @since 0.1.0.0+setDefault :: Store ctx -> ctx -> IO ()+setDefault Store { ref } context = do+  IORef.atomicModifyIORef' ref \state ->+    (state { def = Just context }, ())++-- | 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 = mineMayOnDefault id++mineMayOnDefault :: (Maybe ctx -> Maybe ctx) -> Store ctx -> IO (Maybe ctx)+mineMayOnDefault onDefault Store { ref } = do+  threadId <- Concurrent.myThreadId+  State { stacks, def } <- IORef.readIORef ref+  pure+    case Map.lookup threadId stacks of+      Nothing -> onDefault def+      Just [] -> bug "mineMayOnDefault"+      Just (context : _rest) -> Just context++-- | Register a context in the specified 'Store' on behalf of the calling+-- 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)++-- | 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'+-- as an implementation detail.+--+-- 'Context.withNonEmptyStore'/'Context.withEmptyStore' should generally be preferred over this+-- function when acquiring a 'Store'.+--+-- @since 0.1.0.0+withStore+  :: PropagationStrategy+  -- ^ The strategy used by "Context.Concurrent" for propagating context from a+  -- "parent" thread to a new thread.+  -> Maybe ctx+  -- ^ The default value for the 'Store'.+  --+  -- Providing a value will produce a non-empty 'Store' such that 'Context.mine',+  -- 'Context.mines', and 'Context.adjust' are guaranteed to never throw 'Context.NotFoundException'+  -- when applied to this 'Store'.+  --+  -- Providing 'Nothing' will produce an empty 'Store' such that 'Context.mine',+  -- '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+withStore propagationStrategy mContext f = do+  store <- newStore propagationStrategy mContext+  Exception.finally (f store) do+    case propagationStrategy of+      NoPropagation -> pure ()+      LatestPropagation -> 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:+--+-- > store :: Store Int+-- > store = unsafePerformIO $ Context.newStore Context.defaultPropagation Nothing+-- > {-# NOINLINE store #-}+--+-- Outside of the global variable use case, 'Context.withNonEmptyStore',+-- 'Context.withEmptyStore', or even the lower-level+-- 'Context.Storage.withStore' should /always/ be preferred over this function+-- when acquiring a 'Store'.+--+-- @since 0.1.0.0+newStore+  :: PropagationStrategy+  -- ^ The strategy used by "Context.Concurrent" for propagating context from a+  -- "parent" thread to a new thread.+  -> Maybe ctx+  -- ^ The default value for the 'Store'.+  --+  -- Providing a value will produce a non-empty 'Store' such that 'Context.mine',+  -- 'Context.mines', and 'Context.adjust' are guaranteed to never throw 'Context.NotFoundException'+  -- when applied to this 'Store'.+  --+  -- Providing 'Nothing' will produce an empty 'Store' such that 'Context.mine',+  -- '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)+newStore propagationStrategy def = do+  key <- Unique.newUnique+  ref <- IORef.newIORef State { stacks = Map.empty, def }+  let store = Store { ref, key }+  case propagationStrategy of+    NoPropagation -> pure ()+    LatestPropagation -> register registry store+  pure store++push :: Store ctx -> ctx -> IO ()+push Store { ref } context = do+  threadId <- Concurrent.myThreadId+  IORef.atomicModifyIORef' ref \state@State { stacks } ->+    case Map.lookup threadId stacks of+      Nothing ->+        (state { stacks = Map.insert threadId [context] stacks }, ())+      Just contexts ->+        (state { stacks = Map.insert threadId (context : contexts) stacks}, ())++pop :: Store ctx -> IO ()+pop Store { ref } = do+  threadId <- Concurrent.myThreadId+  IORef.atomicModifyIORef' ref \state@State { stacks } ->+    case Map.lookup threadId stacks of+      Nothing -> bug "pop-1"+      Just [] -> bug "pop-2"++      Just [_context] ->+        (state { stacks = Map.delete threadId stacks }, ())+      Just (_context : rest) ->+        (state { stacks = Map.insert threadId rest stacks }, ())++data AnyStore where+  MkAnyStore :: forall ctx. Store ctx -> AnyStore++newtype Registry = Registry+  { ref :: IORef (Map Unique AnyStore)+  }++registry :: Registry+registry = unsafePerformIO emptyRegistry+{-# NOINLINE registry #-}++emptyRegistry :: IO Registry+emptyRegistry = do+  ref <- IORef.newIORef Map.empty+  pure Registry { ref }++withPropagator :: ((IO a -> IO a) -> IO b) -> IO b+withPropagator = withRegisteredPropagator registry++-- The with-style here is not necessary but it helps keep calling code honest by+-- encouraging not holding onto the propagator any longer than needed. It also+-- makes the signature compatible if the registry's state is ever changed to an+-- MVar and withMVar is used within this function. At this time, an IORef is+-- sufficient because while other stores could be registered after the calling+-- thread reads from the IORef, it would be impossible for the calling thread to+-- have any contexts in those new stores, so there would be nothing to propagate+-- from them.+withRegisteredPropagator :: Registry -> ((IO a -> IO a) -> IO b) -> IO b+withRegisteredPropagator Registry { ref } f = do+  stores <- IORef.readIORef ref+  propagator <- do+    fmap (foldr (.) id) do+      Traversable.for stores \case+        MkAnyStore store -> do+          -- N.B. When propagating context and the "parent" thread doesn't+          -- have any specific context in this particular store but there is+          -- a default, if we just used mineMay directly we would grab the+          -- default and then unnecessarily propagate it as a specific context+          -- for the new thread. Here we override the default value to Nothing+          -- as an optimization.+          mineMayOnDefault (const Nothing) store >>= \case+            Nothing -> pure id+            Just context -> pure $ use store context+  f propagator++register :: Registry -> Store ctx -> IO ()+register Registry { ref } store@Store { key } = do+  IORef.atomicModifyIORef' ref \stores ->+    (Map.insert key (MkAnyStore store) stores, ())++unregister :: Registry -> Store ctx -> IO ()+unregister Registry { ref } Store { key } = do+  IORef.atomicModifyIORef' ref \stores ->+    (Map.delete key stores, ())++bug :: HasCallStack => String -> a+bug prefix =+  error+    $ "Context." <> prefix <> ": Impossible! (if you see this message, please "+        <> "report it as a bug at https://github.com/jship/context)"++-- $disclaimer+--+-- In general, changes to this module will not be reflected in the library's+-- version updates. Direct use of this module should be done with /extreme/ care+-- as it becomes very easy to violate the library's invariants.

@@ -0,0 +1,58 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE StrictData #-}++module Context.Storage+  ( -- * Introduction+    -- $intro++    -- * Lower-level storage+    withStore+  , newStore+  , setDefault++    -- ** Propagation strategies+  , PropagationStrategy+  , defaultPropagation+  , noPropagation+  ) where++import Context.Internal (PropagationStrategy(LatestPropagation, NoPropagation), newStore, setDefault, withStore)++-- | The default 'PropagationStrategy'. For any 'Context.Store' initialized with this+-- 'PropagationStrategy', "Context.Concurrent" will automatically propagate the+-- "parent" thread's latest context value from this 'Context.Store' so that that context+-- is accessible in a newly-created thread.+--+-- @since 0.1.0.0+defaultPropagation :: PropagationStrategy+defaultPropagation = LatestPropagation++-- | This 'PropagationStrategy' does no propagation whatsoever. For any 'Context.Store'+-- initialized with this 'PropagationStrategy', "Context.Concurrent" will /not/+-- propagate the "parent" thread's context values from this 'Context.Store' in any way+-- to the newly-created thread.+--+-- @since 0.1.0.0+noPropagation :: PropagationStrategy+noPropagation = NoPropagation++-- $intro+--+-- This module provides lower-level functions for acquiring and working with+-- 'Context.Store' values. It may be useful for:+--+--   * library authors using a 'Context.Store' value(s) as an implementation+--     detail+--   * application developers leveraging a global 'Context.Store' value(s)+--+-- In any case, this module provides more fine-grained control over+-- 'Context.Store' creation. The most important aspect of this control is being+-- able to precisely specify how "Context.Concurrent" will behave in regards to+-- context propagation.+--+-- While this module is lower-level than the "Context" module, it is still+-- re-exported from "Context" out of convenience.

@@ -0,0 +1,47 @@+name: context+version: '0.1.0.0'+github: "jship/context"+license: MIT+license-file: LICENSE.md+copyright: 2020 (c) Jason Shipman+author: "Jason Shipman"+maintainer: "Jason Shipman"+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+  ask for their current context.+category: Data++extra-source-files:+- CHANGELOG.md+- LICENSE.md+- package.yaml+- README.md++ghc-options:+  - -Wall+  - -fwarn-tabs+  - -Wincomplete-uni-patterns+  - -Wredundant-constraints++library:+  dependencies:+  - base >=4.12 && <5+  - containers >=0.6.0.1 && <0.7+  source-dirs: library++tests:+  context-test-suite:+    source-dirs: test-suite+    main: Driver.hs+    build-tools:+    - hspec-discover+    dependencies:+    - async+    - base+    - ghc-prim+    - hspec+    - context+    ghc-options:+    - -threaded

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,433 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeApplications #-}++module Test.Context.ConcurrentSpec+  ( spec+  ) where++import Prelude+import Test.Hspec+import qualified Context+import qualified Control.Monad as Monad++data Thing = Thing+  { stuff :: Int+  } deriving stock (Eq, Show)++spec :: Spec+spec = do+  describe "forkIO" do+    describe "mineMay" do+      it "empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore @Thing \store1 -> do+          Context.withEmptyStore @Char \store2 -> do+            Monad.void $ Context.forkIO do+              Context.mineMay store1 `shouldReturn` Nothing+              Context.mineMay store2 `shouldReturn` Nothing+              Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with registered context" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.withEmptyStore \store2 -> do+              Context.use store2 'a' do+                Monad.void $ Context.forkIO do+                  Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                  Context.mineMay store2 `shouldReturn` Just 'a'+                  Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with nested contexts" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.use store1 Thing { stuff = 2 } do+              Context.withEmptyStore \store2 -> do+                Context.use store2 'a' do+                  Context.use store2 'b' do+                    Monad.void $ Context.forkIO do+                      Context.mineMay store1 `shouldReturn` Just Thing { stuff = 2 }+                      Context.mineMay store2 `shouldReturn` Just 'b'+                      Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "non-empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withNonEmptyStore Thing { stuff = 1 } \store1 -> do+          Context.withNonEmptyStore 'a' \store2 -> do+            Monad.void $ Context.forkIO do+              Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+              Context.mineMay store2 `shouldReturn` Just 'a'+              Context.putMVar threadDone ()+        Context.takeMVar threadDone++  describe "forkFinally" do+    describe "mineMay" do+      it "empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore @Thing \store1 -> do+          Context.withEmptyStore @Char \store2 -> do+            let checkStores = do+                  Context.mineMay store1 `shouldReturn` Nothing+                  Context.mineMay store2 `shouldReturn` Nothing+            Monad.void $ Context.forkFinally checkStores \_eResult -> do+              checkStores+              Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with registered context" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.withEmptyStore \store2 -> do+              Context.use store2 'a' do+                let checkStores = do+                      Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                      Context.mineMay store2 `shouldReturn` Just 'a'+                Monad.void $ Context.forkFinally checkStores \_eResult -> do+                  checkStores+                  Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with nested contexts" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.use store1 Thing { stuff = 2 } do+              Context.withEmptyStore \store2 -> do+                Context.use store2 'a' do+                  Context.use store2 'b' do+                    let checkStores = do+                          Context.mineMay store1 `shouldReturn` Just Thing { stuff = 2 }+                          Context.mineMay store2 `shouldReturn` Just 'b'+                    Monad.void $ Context.forkFinally checkStores \_eResult -> do+                      checkStores+                      Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "non-empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withNonEmptyStore Thing { stuff = 1 } \store1 -> do+          Context.withNonEmptyStore 'a' \store2 -> do+            let checkStores = do+                  Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                  Context.mineMay store2 `shouldReturn` Just 'a'+            Monad.void $ Context.forkFinally checkStores \_eResult -> do+              checkStores+              Context.putMVar threadDone ()+        Context.takeMVar threadDone++  describe "forkIOWithUnmask" do+    describe "mineMay" do+      it "empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore @Thing \store1 -> do+          Context.withEmptyStore @Char \store2 -> do+            Monad.void $ Context.forkIOWithUnmask \_restore -> do+              Context.mineMay store1 `shouldReturn` Nothing+              Context.mineMay store2 `shouldReturn` Nothing+              Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with registered context" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.withEmptyStore \store2 -> do+              Context.use store2 'a' do+                Monad.void $ Context.forkIOWithUnmask \_restore -> do+                  Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                  Context.mineMay store2 `shouldReturn` Just 'a'+                  Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with nested contexts" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.use store1 Thing { stuff = 2 } do+              Context.withEmptyStore \store2 -> do+                Context.use store2 'a' do+                  Context.use store2 'b' do+                    Monad.void $ Context.forkIOWithUnmask \_restore -> do+                      Context.mineMay store1 `shouldReturn` Just Thing { stuff = 2 }+                      Context.mineMay store2 `shouldReturn` Just 'b'+                      Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "non-empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withNonEmptyStore Thing { stuff = 1 } \store1 -> do+          Context.withNonEmptyStore 'a' \store2 -> do+            Monad.void $ Context.forkIOWithUnmask \_restore -> do+              Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+              Context.mineMay store2 `shouldReturn` Just 'a'+              Context.putMVar threadDone ()+        Context.takeMVar threadDone++  describe "forkOn" do+    describe "mineMay" do+      it "empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore @Thing \store1 -> do+          Context.withEmptyStore @Char \store2 -> do+            Monad.void $ Context.forkOn 1 do+              Context.mineMay store1 `shouldReturn` Nothing+              Context.mineMay store2 `shouldReturn` Nothing+              Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with registered context" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.withEmptyStore \store2 -> do+              Context.use store2 'a' do+                Monad.void $ Context.forkOn 1 do+                  Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                  Context.mineMay store2 `shouldReturn` Just 'a'+                  Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with nested contexts" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.use store1 Thing { stuff = 2 } do+              Context.withEmptyStore \store2 -> do+                Context.use store2 'a' do+                  Context.use store2 'b' do+                    Monad.void $ Context.forkOn 1 do+                      Context.mineMay store1 `shouldReturn` Just Thing { stuff = 2 }+                      Context.mineMay store2 `shouldReturn` Just 'b'+                      Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "non-empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withNonEmptyStore Thing { stuff = 1 } \store1 -> do+          Context.withNonEmptyStore 'a' \store2 -> do+            Monad.void $ Context.forkOn 1 do+              Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+              Context.mineMay store2 `shouldReturn` Just 'a'+              Context.putMVar threadDone ()+        Context.takeMVar threadDone++  describe "forkOnWithUnmask" do+    describe "mineMay" do+      it "empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore @Thing \store1 -> do+          Context.withEmptyStore @Char \store2 -> do+            Monad.void $ Context.forkOnWithUnmask 1 \_restore -> do+              Context.mineMay store1 `shouldReturn` Nothing+              Context.mineMay store2 `shouldReturn` Nothing+              Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with registered context" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.withEmptyStore \store2 -> do+              Context.use store2 'a' do+                Monad.void $ Context.forkOnWithUnmask 1 \_restore -> do+                  Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                  Context.mineMay store2 `shouldReturn` Just 'a'+                  Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with nested contexts" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.use store1 Thing { stuff = 2 } do+              Context.withEmptyStore \store2 -> do+                Context.use store2 'a' do+                  Context.use store2 'b' do+                    Monad.void $ Context.forkOnWithUnmask 1 \_restore -> do+                      Context.mineMay store1 `shouldReturn` Just Thing { stuff = 2 }+                      Context.mineMay store2 `shouldReturn` Just 'b'+                      Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "non-empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withNonEmptyStore Thing { stuff = 1 } \store1 -> do+          Context.withNonEmptyStore 'a' \store2 -> do+            Monad.void $ Context.forkOnWithUnmask 1 \_restore -> do+              Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+              Context.mineMay store2 `shouldReturn` Just 'a'+              Context.putMVar threadDone ()+        Context.takeMVar threadDone++  describe "forkOS" do+    describe "mineMay" do+      it "empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore @Thing \store1 -> do+          Context.withEmptyStore @Char \store2 -> do+            Monad.void $ Context.forkOS do+              Context.mineMay store1 `shouldReturn` Nothing+              Context.mineMay store2 `shouldReturn` Nothing+              Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with registered context" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.withEmptyStore \store2 -> do+              Context.use store2 'a' do+                Monad.void $ Context.forkOS do+                  Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                  Context.mineMay store2 `shouldReturn` Just 'a'+                  Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with nested contexts" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.use store1 Thing { stuff = 2 } do+              Context.withEmptyStore \store2 -> do+                Context.use store2 'a' do+                  Context.use store2 'b' do+                    Monad.void $ Context.forkOS do+                      Context.mineMay store1 `shouldReturn` Just Thing { stuff = 2 }+                      Context.mineMay store2 `shouldReturn` Just 'b'+                      Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "non-empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withNonEmptyStore Thing { stuff = 1 } \store1 -> do+          Context.withNonEmptyStore 'a' \store2 -> do+            Monad.void $ Context.forkOS do+              Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+              Context.mineMay store2 `shouldReturn` Just 'a'+              Context.putMVar threadDone ()+        Context.takeMVar threadDone++  describe "forkOSWithUnmask" do+    describe "mineMay" do+      it "empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore @Thing \store1 -> do+          Context.withEmptyStore @Char \store2 -> do+            Monad.void $ Context.forkOSWithUnmask \_restore -> do+              Context.mineMay store1 `shouldReturn` Nothing+              Context.mineMay store2 `shouldReturn` Nothing+              Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with registered context" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.withEmptyStore \store2 -> do+              Context.use store2 'a' do+                Monad.void $ Context.forkOSWithUnmask \_restore -> do+                  Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                  Context.mineMay store2 `shouldReturn` Just 'a'+                  Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with nested contexts" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.use store1 Thing { stuff = 2 } do+              Context.withEmptyStore \store2 -> do+                Context.use store2 'a' do+                  Context.use store2 'b' do+                    Monad.void $ Context.forkOSWithUnmask \_restore -> do+                      Context.mineMay store1 `shouldReturn` Just Thing { stuff = 2 }+                      Context.mineMay store2 `shouldReturn` Just 'b'+                      Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "non-empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withNonEmptyStore Thing { stuff = 1 } \store1 -> do+          Context.withNonEmptyStore 'a' \store2 -> do+            Monad.void $ Context.forkOSWithUnmask \_restore -> do+              Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+              Context.mineMay store2 `shouldReturn` Just 'a'+              Context.putMVar threadDone ()+        Context.takeMVar threadDone++  describe "runInBoundThread" do+    describe "mineMay" do+      it "empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore @Thing \store1 -> do+          Context.withEmptyStore @Char \store2 -> do+            Context.runInBoundThread do+              Context.mineMay store1 `shouldReturn` Nothing+              Context.mineMay store2 `shouldReturn` Nothing+              Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with registered context" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.withEmptyStore \store2 -> do+              Context.use store2 'a' do+                Context.runInBoundThread do+                  Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                  Context.mineMay store2 `shouldReturn` Just 'a'+                  Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with nested contexts" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.use store1 Thing { stuff = 2 } do+              Context.withEmptyStore \store2 -> do+                Context.use store2 'a' do+                  Context.use store2 'b' do+                    Context.runInBoundThread do+                      Context.mineMay store1 `shouldReturn` Just Thing { stuff = 2 }+                      Context.mineMay store2 `shouldReturn` Just 'b'+                      Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "non-empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withNonEmptyStore Thing { stuff = 1 } \store1 -> do+          Context.withNonEmptyStore 'a' \store2 -> do+            Context.runInBoundThread do+              Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+              Context.mineMay store2 `shouldReturn` Just 'a'+              Context.putMVar threadDone ()+        Context.takeMVar threadDone++  describe "runInUnboundThread" do+    describe "mineMay" do+      it "empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore @Thing \store1 -> do+          Context.withEmptyStore @Char \store2 -> do+            Context.runInUnboundThread do+              Context.mineMay store1 `shouldReturn` Nothing+              Context.mineMay store2 `shouldReturn` Nothing+              Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with registered context" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.withEmptyStore \store2 -> do+              Context.use store2 'a' do+                Context.runInUnboundThread do+                  Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+                  Context.mineMay store2 `shouldReturn` Just 'a'+                  Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "initially-empty stores with nested contexts" do+        threadDone <- Context.newEmptyMVar+        Context.withEmptyStore \store1 -> do+          Context.use store1 Thing { stuff = 1 } do+            Context.use store1 Thing { stuff = 2 } do+              Context.withEmptyStore \store2 -> do+                Context.use store2 'a' do+                  Context.use store2 'b' do+                    Context.runInUnboundThread do+                      Context.mineMay store1 `shouldReturn` Just Thing { stuff = 2 }+                      Context.mineMay store2 `shouldReturn` Just 'b'+                      Context.putMVar threadDone ()+        Context.takeMVar threadDone+      it "non-empty stores" do+        threadDone <- Context.newEmptyMVar+        Context.withNonEmptyStore Thing { stuff = 1 } \store1 -> do+          Context.withNonEmptyStore 'a' \store2 -> do+            Context.runInUnboundThread do+              Context.mineMay store1 `shouldReturn` Just Thing { stuff = 1 }+              Context.mineMay store2 `shouldReturn` Just 'a'+              Context.putMVar threadDone ()+        Context.takeMVar threadDone

@@ -0,0 +1,248 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeApplications #-}++module Test.Context.ImplicitSpec+  ( spec+  ) where++import Context.Implicit (Store)+import Control.Concurrent (ThreadId)+import GHC.Classes (IP(ip))+import Prelude+import System.IO.Unsafe (unsafePerformIO)+import Test.Hspec+import qualified Context.Implicit as Context+import qualified Control.Concurrent as Concurrent+import qualified Control.Concurrent.Async as Async++data Thing = Thing+  { stuff :: Int+  } deriving stock (Eq, Show)++store :: Store Thing+store = unsafePerformIO $ Context.newStore Context.defaultPropagation Nothing+{-# NOINLINE store #-}++instance IP "contextStore" (Store Thing) where+  ip = store++spec :: Spec+spec = do+  describe "emptyStore" do+    describe "mineMay" do+      it "empty" do+        Context.mineMay `shouldReturn` Nothing+      it "single context" do+        Context.use Thing { stuff = 1 } do+          Context.mineMay `shouldReturn` Just Thing { stuff = 1 }+        Context.mineMay `shouldReturn` Nothing+      it "nested contexts" do+        Context.use Thing { stuff = 1 } do+          Context.mineMay `shouldReturn` Just Thing { stuff = 1 }+          Context.use Thing { stuff = 2 } do+            Context.mineMay `shouldReturn` Just Thing { stuff = 2 }+            Context.use Thing { stuff = 3 } do+              Context.mineMay `shouldReturn` Just Thing { stuff = 3 }+            Context.mineMay `shouldReturn` Just Thing { stuff = 2 }+          Context.use Thing { stuff = 4 } do+            Context.mineMay `shouldReturn` Just Thing { stuff = 4 }+          Context.mineMay `shouldReturn` Just Thing { stuff = 1 }+        Context.mineMay `shouldReturn` Nothing+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Async.forConcurrently_ [1 :: Int ..10] $ const do+          Context.mineMay `shouldReturn` Nothing+          Context.use (mkContext 1) do+            Context.mineMay `shouldReturn` Just (mkContext 1)+            Context.use (mkContext 2) do+              Context.mineMay `shouldReturn` Just (mkContext 2)+              Context.use (mkContext 3) do+                Context.mineMay `shouldReturn` Just (mkContext 3)+              Context.mineMay `shouldReturn` Just (mkContext 2)+            Context.use (mkContext 4) do+              Context.mineMay `shouldReturn` Just (mkContext 4)+            Context.mineMay `shouldReturn` Just (mkContext 1)+          Context.mineMay `shouldReturn` Nothing+        Context.mineMay `shouldReturn` Nothing++    describe "minesMay" do+      it "empty" do+        Context.minesMay stuff `shouldReturn` Nothing+      it "single context" do+        Context.use Thing { stuff = 1 } do+          Context.minesMay stuff `shouldReturn` Just 1+        Context.minesMay stuff `shouldReturn` Nothing+      it "nested contexts" do+        Context.use Thing { stuff = 1 } do+          Context.minesMay stuff `shouldReturn` Just 1+          Context.use Thing { stuff = 2 } do+            Context.minesMay stuff `shouldReturn` Just 2+            Context.use Thing { stuff = 3 } do+              Context.minesMay stuff `shouldReturn` Just 3+            Context.minesMay stuff `shouldReturn` Just 2+          Context.use Thing { stuff = 4 } do+            Context.minesMay stuff `shouldReturn` Just 4+          Context.minesMay stuff `shouldReturn` Just 1+        Context.minesMay stuff `shouldReturn` Nothing+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Async.forConcurrently_ [1 :: Int ..10] $ const do+          Context.minesMay stuff `shouldReturn` Nothing+          Context.use (mkContext 1) do+            Context.minesMay stuff `shouldReturn` Just 1+            Context.use (mkContext 2) do+              Context.minesMay stuff `shouldReturn` Just 2+              Context.use (mkContext 3) do+                Context.minesMay stuff `shouldReturn` Just 3+              Context.minesMay stuff `shouldReturn` Just 2+            Context.use (mkContext 4) do+              Context.minesMay stuff `shouldReturn` Just 4+            Context.minesMay stuff `shouldReturn` Just 1+          Context.minesMay stuff `shouldReturn` Nothing+        Context.minesMay stuff `shouldReturn` Nothing++    describe "mine" do+      it "empty" do+        threadId <- Concurrent.myThreadId+        Context.mine `shouldThrow` notFound threadId+      it "single context" do+        threadId <- Concurrent.myThreadId+        Context.use Thing { stuff = 1 } do+          Context.mine `shouldReturn` Thing { stuff = 1 }+        Context.mine `shouldThrow` notFound threadId+      it "nested contexts" do+        threadId <- Concurrent.myThreadId+        Context.use Thing { stuff = 1 } do+          Context.mine `shouldReturn` Thing { stuff = 1 }+          Context.use Thing { stuff = 2 } do+            Context.mine `shouldReturn` Thing { stuff = 2 }+            Context.use Thing { stuff = 3 } do+              Context.mine `shouldReturn` Thing { stuff = 3 }+            Context.mine `shouldReturn` Thing { stuff = 2 }+          Context.use Thing { stuff = 4 } do+            Context.mine `shouldReturn` Thing { stuff = 4 }+          Context.mine `shouldReturn` Thing { stuff = 1 }+        Context.mine `shouldThrow` notFound threadId+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        initThreadId <- Concurrent.myThreadId+        Async.forConcurrently_ [1 :: Int ..10] $ const do+          threadId <- Concurrent.myThreadId+          Context.mine `shouldThrow` notFound threadId+          Context.use (mkContext 1) do+            Context.mine `shouldReturn` mkContext 1+            Context.use (mkContext 2) do+              Context.mine `shouldReturn` mkContext 2+              Context.use (mkContext 3) do+                Context.mine `shouldReturn` mkContext 3+              Context.mine `shouldReturn` mkContext 2+            Context.use (mkContext 4) do+              Context.mine `shouldReturn` mkContext 4+            Context.mine `shouldReturn` mkContext 1+          Context.mine `shouldThrow` notFound threadId+        Context.mine `shouldThrow` notFound initThreadId++    describe "mines" do+      it "empty" do+        threadId <- Concurrent.myThreadId+        Context.mines stuff `shouldThrow` notFound threadId+      it "single context" do+        threadId <- Concurrent.myThreadId+        Context.use Thing { stuff = 1 } do+          Context.mines stuff `shouldReturn` 1+        Context.mines stuff `shouldThrow` notFound threadId+      it "nested contexts" do+        threadId <- Concurrent.myThreadId+        Context.use Thing { stuff = 1 } do+          Context.mines stuff `shouldReturn` 1+          Context.use Thing { stuff = 2 } do+            Context.mines stuff `shouldReturn` 2+            Context.use Thing { stuff = 3 } do+              Context.mines stuff `shouldReturn` 3+            Context.mines stuff `shouldReturn` 2+          Context.use Thing { stuff = 4 } do+            Context.mines stuff `shouldReturn` 4+          Context.mines stuff `shouldReturn` 1+        Context.mines stuff `shouldThrow` notFound threadId+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        initThreadId <- Concurrent.myThreadId+        Async.forConcurrently_ [1 :: Int ..10] $ const do+          threadId <- Concurrent.myThreadId+          Context.mine `shouldThrow` notFound threadId+          Context.use (mkContext 1) do+            Context.mines stuff `shouldReturn` 1+            Context.use (mkContext 2) do+              Context.mines stuff `shouldReturn` 2+              Context.use (mkContext 3) do+                Context.mines stuff `shouldReturn` 3+              Context.mines stuff `shouldReturn` 2+            Context.use (mkContext 4) do+              Context.mines stuff `shouldReturn` 4+            Context.mines stuff `shouldReturn` 1+          Context.mines stuff `shouldThrow` notFound threadId+        Context.mines stuff `shouldThrow` notFound initThreadId++    describe "adjust" do+      it "empty" do+        threadId <- Concurrent.myThreadId+        Context.adjust modifier (error "does not get here")+          `shouldThrow` notFound threadId+      it "single context" do+        threadId <- Concurrent.myThreadId+        Context.use Thing { stuff = 1 } do+          Context.mine `shouldReturn` Thing { stuff = 1 }+          Context.adjust modifier do+            Context.mine `shouldReturn` Thing { stuff = 2 }+          Context.mine `shouldReturn` Thing { stuff = 1 }+        Context.mine `shouldThrow` notFound threadId+      it "nested contexts" do+        threadId <- Concurrent.myThreadId+        Context.use Thing { stuff = 1 } do+          Context.adjust modifier do+            Context.mine `shouldReturn` Thing { stuff = 2 }+            Context.use Thing { stuff = 3 } do+              Context.mine `shouldReturn` Thing { stuff = 3 }+              Context.use Thing { stuff = 4 } do+                Context.mine `shouldReturn` Thing { stuff = 4 }+              Context.mine `shouldReturn` Thing { stuff = 3 }+            Context.use Thing { stuff = 4 } do+              Context.mine `shouldReturn` Thing { stuff = 4 }+            Context.mine `shouldReturn` Thing { stuff = 2 }+          Context.mine `shouldReturn` Thing { stuff = 1 }+        Context.mine `shouldThrow` notFound threadId+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        initThreadId <- Concurrent.myThreadId+        Async.forConcurrently_ [1 :: Int ..10] $ const do+          threadId <- Concurrent.myThreadId+          Context.mine `shouldThrow` notFound threadId+          Context.use (mkContext 1) do+            Context.adjust modifier do+              Context.mine `shouldReturn` mkContext 2+              Context.use (mkContext 3) do+                Context.mine `shouldReturn` mkContext 3+                Context.use (mkContext 4) do+                  Context.mine `shouldReturn` mkContext 4+                Context.mine `shouldReturn` mkContext 3+              Context.use (mkContext 5) do+                Context.mine `shouldReturn` mkContext 5+              Context.mine `shouldReturn` mkContext 2+            Context.mine `shouldReturn` mkContext 1+          Context.mine `shouldThrow` notFound threadId+        Context.mine `shouldThrow` notFound initThreadId++notFound :: ThreadId -> Context.NotFoundException -> Bool+notFound threadId notFoundEx =+  Context.NotFoundException { Context.threadId } == notFoundEx++modifier :: Thing -> Thing+modifier thing = thing { stuff = 2 * stuff thing }

@@ -0,0 +1,479 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TypeApplications #-}++module Test.ContextSpec+  ( spec+  ) where++import Control.Concurrent (ThreadId)+import Prelude+import Test.Hspec+import qualified Context+import qualified Control.Concurrent as Concurrent+import qualified Control.Concurrent.Async as Async++data Thing = Thing+  { stuff :: Int+  } deriving stock (Eq, Show)++spec :: Spec+spec = do+  describe "withEmptyStore" do+    describe "mineMay" do+      it "empty" do+        Context.withEmptyStore @Thing \store -> do+          Context.mineMay store `shouldReturn` Nothing+      it "single context" do+        Context.withEmptyStore @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.use store Thing { stuff = 1 } do+            Context.mineMay store `shouldReturn` Just Thing { stuff = 1 }+            Context.use store Thing { stuff = 2 } do+              Context.mineMay store `shouldReturn` Just Thing { stuff = 2 }+              Context.use store Thing { stuff = 3 } do+                Context.mineMay store `shouldReturn` Just Thing { stuff = 3 }+              Context.mineMay store `shouldReturn` Just Thing { stuff = 2 }+            Context.use store Thing { stuff = 4 } do+              Context.mineMay store `shouldReturn` Just Thing { stuff = 4 }+            Context.mineMay store `shouldReturn` Just Thing { stuff = 1 }+          Context.mineMay store `shouldReturn` Nothing+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Context.withEmptyStore @Thing \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            Context.mineMay store `shouldReturn` Nothing+            Context.use store (mkContext 1) do+              Context.mineMay store `shouldReturn` Just (mkContext 1)+              Context.use store (mkContext 2) do+                Context.mineMay store `shouldReturn` Just (mkContext 2)+                Context.use store (mkContext 3) do+                  Context.mineMay store `shouldReturn` Just (mkContext 3)+                Context.mineMay store `shouldReturn` Just (mkContext 2)+              Context.use store (mkContext 4) do+                Context.mineMay store `shouldReturn` Just (mkContext 4)+              Context.mineMay store `shouldReturn` Just (mkContext 1)+            Context.mineMay store `shouldReturn` Nothing+          Context.mineMay store `shouldReturn` Nothing++    describe "minesMay" do+      it "empty" do+        Context.withEmptyStore @Thing \store -> do+          Context.minesMay store stuff `shouldReturn` Nothing+      it "single context" do+        Context.withEmptyStore @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.use store Thing { stuff = 1 } do+            Context.minesMay store stuff `shouldReturn` Just 1+            Context.use store Thing { stuff = 2 } do+              Context.minesMay store stuff `shouldReturn` Just 2+              Context.use store Thing { stuff = 3 } do+                Context.minesMay store stuff `shouldReturn` Just 3+              Context.minesMay store stuff `shouldReturn` Just 2+            Context.use store Thing { stuff = 4 } do+              Context.minesMay store stuff `shouldReturn` Just 4+            Context.minesMay store stuff `shouldReturn` Just 1+          Context.minesMay store stuff `shouldReturn` Nothing+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Context.withEmptyStore @Thing \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            Context.minesMay store stuff `shouldReturn` Nothing+            Context.use store (mkContext 1) do+              Context.minesMay store stuff `shouldReturn` Just 1+              Context.use store (mkContext 2) do+                Context.minesMay store stuff `shouldReturn` Just 2+                Context.use store (mkContext 3) do+                  Context.minesMay store stuff `shouldReturn` Just 3+                Context.minesMay store stuff `shouldReturn` Just 2+              Context.use store (mkContext 4) do+                Context.minesMay store stuff `shouldReturn` Just 4+              Context.minesMay store stuff `shouldReturn` Just 1+            Context.minesMay store stuff `shouldReturn` Nothing+          Context.minesMay store stuff `shouldReturn` Nothing++    describe "mine" do+      it "empty" do+        Context.withEmptyStore @Thing \store -> do+          threadId <- Concurrent.myThreadId+          Context.mine store `shouldThrow` notFound threadId+      it "single context" do+        Context.withEmptyStore @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+          threadId <- Concurrent.myThreadId+          Context.use store Thing { stuff = 1 } do+            Context.mine store `shouldReturn` Thing { stuff = 1 }+            Context.use store Thing { stuff = 2 } do+              Context.mine store `shouldReturn` Thing { stuff = 2 }+              Context.use store Thing { stuff = 3 } do+                Context.mine store `shouldReturn` Thing { stuff = 3 }+              Context.mine store `shouldReturn` Thing { stuff = 2 }+            Context.use store Thing { stuff = 4 } do+              Context.mine store `shouldReturn` Thing { stuff = 4 }+            Context.mine store `shouldReturn` Thing { stuff = 1 }+          Context.mine store `shouldThrow` notFound threadId+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        initThreadId <- Concurrent.myThreadId+        Context.withEmptyStore @Thing \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            threadId <- Concurrent.myThreadId+            Context.mine store `shouldThrow` notFound threadId+            Context.use store (mkContext 1) do+              Context.mine store `shouldReturn` mkContext 1+              Context.use store (mkContext 2) do+                Context.mine store `shouldReturn` mkContext 2+                Context.use store (mkContext 3) do+                  Context.mine store `shouldReturn` mkContext 3+                Context.mine store `shouldReturn` mkContext 2+              Context.use store (mkContext 4) do+                Context.mine store `shouldReturn` mkContext 4+              Context.mine store `shouldReturn` mkContext 1+            Context.mine store `shouldThrow` notFound threadId+          Context.mine store `shouldThrow` notFound initThreadId++    describe "mines" do+      it "empty" do+        Context.withEmptyStore @Thing \store -> do+          threadId <- Concurrent.myThreadId+          Context.mines store stuff `shouldThrow` notFound threadId+      it "single context" do+        Context.withEmptyStore @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+          threadId <- Concurrent.myThreadId+          Context.use store Thing { stuff = 1 } do+            Context.mines store stuff `shouldReturn` 1+            Context.use store Thing { stuff = 2 } do+              Context.mines store stuff `shouldReturn` 2+              Context.use store Thing { stuff = 3 } do+                Context.mines store stuff `shouldReturn` 3+              Context.mines store stuff `shouldReturn` 2+            Context.use store Thing { stuff = 4 } do+              Context.mines store stuff `shouldReturn` 4+            Context.mines store stuff `shouldReturn` 1+          Context.mines store stuff `shouldThrow` notFound threadId+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        initThreadId <- Concurrent.myThreadId+        Context.withEmptyStore @Thing \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            threadId <- Concurrent.myThreadId+            Context.mine store `shouldThrow` notFound threadId+            Context.use store (mkContext 1) do+              Context.mines store stuff `shouldReturn` 1+              Context.use store (mkContext 2) do+                Context.mines store stuff `shouldReturn` 2+                Context.use store (mkContext 3) do+                  Context.mines store stuff `shouldReturn` 3+                Context.mines store stuff `shouldReturn` 2+              Context.use store (mkContext 4) do+                Context.mines store stuff `shouldReturn` 4+              Context.mines store stuff `shouldReturn` 1+            Context.mines store stuff `shouldThrow` notFound threadId+          Context.mines store stuff `shouldThrow` notFound initThreadId++    describe "adjust" do+      it "empty" do+        Context.withEmptyStore @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+          threadId <- Concurrent.myThreadId+          Context.use store Thing { stuff = 1 } do+            Context.mine store `shouldReturn` Thing { stuff = 1 }+            Context.adjust store modifier do+              Context.mine store `shouldReturn` Thing { stuff = 2 }+            Context.mine store `shouldReturn` Thing { stuff = 1 }+          Context.mine store `shouldThrow` notFound threadId+      it "nested contexts" do+        Context.withEmptyStore @Thing \store -> do+          threadId <- Concurrent.myThreadId+          Context.use store Thing { stuff = 1 } do+            Context.adjust store modifier do+              Context.mine store `shouldReturn` Thing { stuff = 2 }+              Context.use store Thing { stuff = 3 } do+                Context.mine store `shouldReturn` Thing { stuff = 3 }+                Context.use store Thing { stuff = 4 } do+                  Context.mine store `shouldReturn` Thing { stuff = 4 }+                Context.mine store `shouldReturn` Thing { stuff = 3 }+              Context.use store Thing { stuff = 4 } do+                Context.mine store `shouldReturn` Thing { stuff = 4 }+              Context.mine store `shouldReturn` Thing { stuff = 2 }+            Context.mine store `shouldReturn` Thing { stuff = 1 }+          Context.mine store `shouldThrow` notFound threadId+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        initThreadId <- Concurrent.myThreadId+        Context.withEmptyStore @Thing \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            threadId <- Concurrent.myThreadId+            Context.mine store `shouldThrow` notFound threadId+            Context.use store (mkContext 1) do+              Context.adjust store modifier do+                Context.mine store `shouldReturn` mkContext 2+                Context.use store (mkContext 3) do+                  Context.mine store `shouldReturn` mkContext 3+                  Context.use store (mkContext 4) do+                    Context.mine store `shouldReturn` mkContext 4+                  Context.mine store `shouldReturn` mkContext 3+                Context.use store (mkContext 5) do+                  Context.mine store `shouldReturn` mkContext 5+                Context.mine store `shouldReturn` mkContext 2+              Context.mine store `shouldReturn` mkContext 1+            Context.mine store `shouldThrow` notFound threadId+          Context.mine store `shouldThrow` notFound initThreadId++    describe "setDefault" do+      it "setting default converts store to non-empty" do+        Context.withEmptyStore @Thing \store -> do+          Context.mineMay store `shouldReturn` Nothing+          Context.setDefault store Thing { stuff = 1 }+          Context.mineMay store `shouldReturn` Just Thing { stuff = 1 }+          Context.setDefault store Thing { stuff = 2 }+          Context.mineMay store `shouldReturn` Just Thing { stuff = 2 }++  describe "withNonEmptyStore" do+    describe "mineMay" do+      it "default" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.mineMay store `shouldReturn` Just Thing { stuff = 0 }+      it "single context" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.mineMay store `shouldReturn` Just Thing { stuff = 1 }+          Context.mineMay store `shouldReturn` Just Thing { stuff = 0 }+      it "nested contexts" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.mineMay store `shouldReturn` Just Thing { stuff = 1 }+            Context.use store Thing { stuff = 2 } do+              Context.mineMay store `shouldReturn` Just Thing { stuff = 2 }+              Context.use store Thing { stuff = 3 } do+                Context.mineMay store `shouldReturn` Just Thing { stuff = 3 }+              Context.mineMay store `shouldReturn` Just Thing { stuff = 2 }+            Context.use store Thing { stuff = 4 } do+              Context.mineMay store `shouldReturn` Just Thing { stuff = 4 }+            Context.mineMay store `shouldReturn` Just Thing { stuff = 1 }+          Context.mineMay store `shouldReturn` Just Thing { stuff = 0 }+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Context.withNonEmptyStore (mkContext 0) \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            Context.mineMay store `shouldReturn` Just (mkContext 0)+            Context.use store (mkContext 1) do+              Context.mineMay store `shouldReturn` Just (mkContext 1)+              Context.use store (mkContext 2) do+                Context.mineMay store `shouldReturn` Just (mkContext 2)+                Context.use store (mkContext 3) do+                  Context.mineMay store `shouldReturn` Just (mkContext 3)+                Context.mineMay store `shouldReturn` Just (mkContext 2)+              Context.use store (mkContext 4) do+                Context.mineMay store `shouldReturn` Just (mkContext 4)+              Context.mineMay store `shouldReturn` Just (mkContext 1)+            Context.mineMay store `shouldReturn` Just (mkContext 0)+          Context.mineMay store `shouldReturn` Just (mkContext 0)++    describe "minesMay" do+      it "default" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.minesMay store stuff `shouldReturn` Just 0+      it "single context" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.minesMay store stuff `shouldReturn` Just 1+          Context.minesMay store stuff `shouldReturn` Just 0+      it "nested contexts" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.minesMay store stuff `shouldReturn` Just 1+            Context.use store Thing { stuff = 2 } do+              Context.minesMay store stuff `shouldReturn` Just 2+              Context.use store Thing { stuff = 3 } do+                Context.minesMay store stuff `shouldReturn` Just 3+              Context.minesMay store stuff `shouldReturn` Just 2+            Context.use store Thing { stuff = 4 } do+              Context.minesMay store stuff `shouldReturn` Just 4+            Context.minesMay store stuff `shouldReturn` Just 1+          Context.minesMay store stuff `shouldReturn` Just 0+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Context.withNonEmptyStore (mkContext 0) \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            Context.minesMay store stuff `shouldReturn` Just 0+            Context.use store (mkContext 1) do+              Context.minesMay store stuff `shouldReturn` Just 1+              Context.use store (mkContext 2) do+                Context.minesMay store stuff `shouldReturn` Just 2+                Context.use store (mkContext 3) do+                  Context.minesMay store stuff `shouldReturn` Just 3+                Context.minesMay store stuff `shouldReturn` Just 2+              Context.use store (mkContext 4) do+                Context.minesMay store stuff `shouldReturn` Just 4+              Context.minesMay store stuff `shouldReturn` Just 1+            Context.minesMay store stuff `shouldReturn` Just 0+          Context.minesMay store stuff `shouldReturn` Just 0++    describe "mine" do+      it "default" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.mine store `shouldReturn` Thing { stuff = 0 }+      it "single context" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.mine store `shouldReturn` Thing { stuff = 1 }+          Context.mine store `shouldReturn` Thing { stuff = 0 }+      it "nested contexts" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.mine store `shouldReturn` Thing { stuff = 1 }+            Context.use store Thing { stuff = 2 } do+              Context.mine store `shouldReturn` Thing { stuff = 2 }+              Context.use store Thing { stuff = 3 } do+                Context.mine store `shouldReturn` Thing { stuff = 3 }+              Context.mine store `shouldReturn` Thing { stuff = 2 }+            Context.use store Thing { stuff = 4 } do+              Context.mine store `shouldReturn` Thing { stuff = 4 }+            Context.mine store `shouldReturn` Thing { stuff = 1 }+          Context.mine store `shouldReturn` Thing { stuff = 0 }+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Context.withNonEmptyStore (mkContext 0) \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            Context.mine store `shouldReturn` mkContext 0+            Context.use store (mkContext 1) do+              Context.mine store `shouldReturn` mkContext 1+              Context.use store (mkContext 2) do+                Context.mine store `shouldReturn` mkContext 2+                Context.use store (mkContext 3) do+                  Context.mine store `shouldReturn` mkContext 3+                Context.mine store `shouldReturn` mkContext 2+              Context.use store (mkContext 4) do+                Context.mine store `shouldReturn` mkContext 4+              Context.mine store `shouldReturn` mkContext 1+            Context.mine store `shouldReturn` mkContext 0+          Context.mine store `shouldReturn` mkContext 0++    describe "mines" do+      it "default" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.mines store stuff `shouldReturn` 0+      it "single context" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.mines store stuff `shouldReturn` 1+          Context.mines store stuff `shouldReturn` 0+      it "nested contexts" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.mines store stuff `shouldReturn` 1+            Context.use store Thing { stuff = 2 } do+              Context.mines store stuff `shouldReturn` 2+              Context.use store Thing { stuff = 3 } do+                Context.mines store stuff `shouldReturn` 3+              Context.mines store stuff `shouldReturn` 2+            Context.use store Thing { stuff = 4 } do+              Context.mines store stuff `shouldReturn` 4+            Context.mines store stuff `shouldReturn` 1+          Context.mines store stuff `shouldReturn` 0+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Context.withNonEmptyStore (mkContext 0) \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            Context.mines store stuff `shouldReturn` 0+            Context.use store (mkContext 1) do+              Context.mines store stuff `shouldReturn` 1+              Context.use store (mkContext 2) do+                Context.mines store stuff `shouldReturn` 2+                Context.use store (mkContext 3) do+                  Context.mines store stuff `shouldReturn` 3+                Context.mines store stuff `shouldReturn` 2+              Context.use store (mkContext 4) do+                Context.mines store stuff `shouldReturn` 4+              Context.mines store stuff `shouldReturn` 1+            Context.mines store stuff `shouldReturn` 0+          Context.mines store stuff `shouldReturn` 0++    describe "adjust" do+      it "default" do+        Context.withNonEmptyStore Thing { stuff = 1 } \store -> do+          Context.adjust store modifier do+            Context.mine store `shouldReturn` Thing { stuff = 2 }+          Context.mine store `shouldReturn` Thing { stuff = 1 }+      it "single context" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.mine store `shouldReturn` Thing { stuff = 1 }+            Context.adjust store modifier do+              Context.mine store `shouldReturn` Thing { stuff = 2 }+            Context.mine store `shouldReturn` Thing { stuff = 1 }+          Context.mine store `shouldReturn` Thing { stuff = 0 }+      it "nested contexts" do+        Context.withNonEmptyStore Thing { stuff = 0 } \store -> do+          Context.use store Thing { stuff = 1 } do+            Context.adjust store modifier do+              Context.mine store `shouldReturn` Thing { stuff = 2 }+              Context.use store Thing { stuff = 3 } do+                Context.mine store `shouldReturn` Thing { stuff = 3 }+                Context.use store Thing { stuff = 4 } do+                  Context.mine store `shouldReturn` Thing { stuff = 4 }+                Context.mine store `shouldReturn` Thing { stuff = 3 }+              Context.use store Thing { stuff = 4 } do+                Context.mine store `shouldReturn` Thing { stuff = 4 }+              Context.mine store `shouldReturn` Thing { stuff = 2 }+            Context.mine store `shouldReturn` Thing { stuff = 1 }+          Context.mine store `shouldReturn` Thing { stuff = 0 }+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Context.withNonEmptyStore (mkContext 0) \store -> do+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            Context.mine store `shouldReturn` mkContext 0+            Context.use store (mkContext 1) do+              Context.adjust store modifier do+                Context.mine store `shouldReturn` mkContext 2+                Context.use store (mkContext 3) do+                  Context.mine store `shouldReturn` mkContext 3+                  Context.use store (mkContext 4) do+                    Context.mine store `shouldReturn` mkContext 4+                  Context.mine store `shouldReturn` mkContext 3+                Context.use store (mkContext 5) do+                  Context.mine store `shouldReturn` mkContext 5+                Context.mine store `shouldReturn` mkContext 2+              Context.mine store `shouldReturn` mkContext 1+            Context.mine store `shouldReturn` mkContext 0+          Context.mine store `shouldReturn` mkContext 0++    describe "setDefault" do+      it "setting default overrides initial default" do+        Context.withNonEmptyStore Thing { stuff = 1 } \store -> do+          Context.mineMay store `shouldReturn` Just Thing { stuff = 1 }+          Context.setDefault store Thing { stuff = 2 }+          Context.mineMay store `shouldReturn` Just Thing { stuff = 2 }++notFound :: ThreadId -> Context.NotFoundException -> Bool+notFound threadId notFoundEx =+  Context.NotFoundException { Context.threadId } == notFoundEx++modifier :: Thing -> Thing+modifier thing = thing { stuff = 2 * stuff thing }