diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Change log + +## 0.1.0.0 + +Initial release diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 diff --git a/context.cabal b/context.cabal new file mode 100644 --- /dev/null +++ b/context.cabal @@ -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 diff --git a/library/Context.hs b/library/Context.hs new file mode 100644 --- /dev/null +++ b/library/Context.hs @@ -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 diff --git a/library/Context/Concurrent.hs b/library/Context/Concurrent.hs new file mode 100644 --- /dev/null +++ b/library/Context/Concurrent.hs @@ -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. diff --git a/library/Context/Implicit.hs b/library/Context/Implicit.hs new file mode 100644 --- /dev/null +++ b/library/Context/Implicit.hs @@ -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: +-- diff --git a/library/Context/Internal.hs b/library/Context/Internal.hs new file mode 100644 --- /dev/null +++ b/library/Context/Internal.hs @@ -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. diff --git a/library/Context/Storage.hs b/library/Context/Storage.hs new file mode 100644 --- /dev/null +++ b/library/Context/Storage.hs @@ -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. diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -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 diff --git a/test-suite/Driver.hs b/test-suite/Driver.hs new file mode 100644 --- /dev/null +++ b/test-suite/Driver.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test-suite/Test/Context/ConcurrentSpec.hs b/test-suite/Test/Context/ConcurrentSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Test/Context/ConcurrentSpec.hs @@ -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 diff --git a/test-suite/Test/Context/ImplicitSpec.hs b/test-suite/Test/Context/ImplicitSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Test/Context/ImplicitSpec.hs @@ -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 } diff --git a/test-suite/Test/ContextSpec.hs b/test-suite/Test/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test-suite/Test/ContextSpec.hs @@ -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 }