{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}

module Context.Internal
  ( -- * Disclaimer
    -- $disclaimer

    -- ** Store-related
    Store(Store, ref, key)
  , State(State, stacks, def)
  , NotFoundException(NotFoundException, threadId)
  , withStore
  , newStore
  , use
  , push
  , pop
  , mineMay
  , mineMayOnDefault
  , setDefault
  , throwContextNotFound

    -- ** View-related
  , View(MkView)
  , view
  , viewMay
  , toView

    -- ** Propagation-related
  , PropagationStrategy(NoPropagation, LatestPropagation)
  , Registry(Registry, ref)
  , AnyStore(MkAnyStore)
  , registry
  , emptyRegistry
  , withPropagator
  , withRegisteredPropagator
  , register
  , unregister

    -- ** Miscellaneous
  , bug
  ) where

import Control.Concurrent (ThreadId)
import Control.Exception (Exception)
import Control.Monad ((<=<))
import Control.Monad.Catch (MonadMask, MonadThrow)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.IORef (IORef)
import Data.Map.Strict (Map)
import Data.Unique (Unique)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Prelude
import System.IO.Unsafe (unsafePerformIO)
import qualified Control.Concurrent as Concurrent
import qualified Control.Monad.Catch as Catch
import qualified Data.IORef as IORef
import qualified Data.Map.Strict as Map
import qualified Data.Traversable as Traversable
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
  { Store ctx -> IORef (State ctx)
ref :: IORef (State ctx)
  , Store ctx -> Unique
key :: Unique
  }

data State ctx = State
  { State ctx -> Map ThreadId [ctx]
stacks :: Map ThreadId [ctx]
  , State ctx -> Maybe ctx
def :: Maybe ctx
  }

-- | An exception which may be thrown when the calling thread does not have a
-- registered context.
--
-- @since 0.1.0.0
data NotFoundException = NotFoundException
  { NotFoundException -> ThreadId
threadId :: ThreadId
  } deriving stock (NotFoundException -> NotFoundException -> Bool
(NotFoundException -> NotFoundException -> Bool)
-> (NotFoundException -> NotFoundException -> Bool)
-> Eq NotFoundException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NotFoundException -> NotFoundException -> Bool
$c/= :: NotFoundException -> NotFoundException -> Bool
== :: NotFoundException -> NotFoundException -> Bool
$c== :: NotFoundException -> NotFoundException -> Bool
Eq, (forall x. NotFoundException -> Rep NotFoundException x)
-> (forall x. Rep NotFoundException x -> NotFoundException)
-> Generic NotFoundException
forall x. Rep NotFoundException x -> NotFoundException
forall x. NotFoundException -> Rep NotFoundException x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep NotFoundException x -> NotFoundException
$cfrom :: forall x. NotFoundException -> Rep NotFoundException x
Generic, Int -> NotFoundException -> ShowS
[NotFoundException] -> ShowS
NotFoundException -> String
(Int -> NotFoundException -> ShowS)
-> (NotFoundException -> String)
-> ([NotFoundException] -> ShowS)
-> Show NotFoundException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NotFoundException] -> ShowS
$cshowList :: [NotFoundException] -> ShowS
show :: NotFoundException -> String
$cshow :: NotFoundException -> String
showsPrec :: Int -> NotFoundException -> ShowS
$cshowsPrec :: Int -> NotFoundException -> ShowS
Show)
    deriving anyclass Show NotFoundException
Typeable NotFoundException
Typeable NotFoundException
-> Show NotFoundException
-> (NotFoundException -> SomeException)
-> (SomeException -> Maybe NotFoundException)
-> (NotFoundException -> String)
-> Exception NotFoundException
SomeException -> Maybe NotFoundException
NotFoundException -> String
NotFoundException -> SomeException
forall e.
Typeable e
-> Show e
-> (e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> Exception e
displayException :: NotFoundException -> String
$cdisplayException :: NotFoundException -> String
fromException :: SomeException -> Maybe NotFoundException
$cfromException :: SomeException -> Maybe NotFoundException
toException :: NotFoundException -> SomeException
$ctoException :: NotFoundException -> SomeException
$cp2Exception :: Show NotFoundException
$cp1Exception :: Typeable NotFoundException
Exception

-- | 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
  :: forall m ctx
   . (MonadIO m)
  => Store ctx
  -> ctx
  -> m ()
setDefault :: Store ctx -> ctx -> m ()
setDefault Store { IORef (State ctx)
ref :: IORef (State ctx)
$sel:ref:Store :: forall ctx. Store ctx -> IORef (State ctx)
ref } ctx
context = do
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef (State ctx) -> (State ctx -> (State ctx, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (State ctx)
ref ((State ctx -> (State ctx, ())) -> IO ())
-> (State ctx -> (State ctx, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State ctx
state ->
    (State ctx
state { $sel:def:State :: Maybe ctx
def = ctx -> Maybe ctx
forall a. a -> Maybe a
Just ctx
context }, ())

throwContextNotFound
  :: forall m a
   . (MonadIO m, MonadThrow m)
  => m a
throwContextNotFound :: m a
throwContextNotFound = do
  ThreadId
threadId <- IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO ThreadId
Concurrent.myThreadId
  NotFoundException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM (NotFoundException -> m a) -> NotFoundException -> m a
forall a b. (a -> b) -> a -> b
$ NotFoundException :: ThreadId -> NotFoundException
NotFoundException { ThreadId
threadId :: ThreadId
$sel:threadId:NotFoundException :: ThreadId
threadId }

-- | Provide the calling thread its current context from the specified
-- 'Store', if present.
--
-- @since 0.1.0.0
mineMay
  :: forall m ctx
   . (MonadIO m)
  => Store ctx
  -> m (Maybe ctx)
mineMay :: Store ctx -> m (Maybe ctx)
mineMay = (Maybe ctx -> Maybe ctx) -> Store ctx -> m (Maybe ctx)
forall (m :: * -> *) ctx.
MonadIO m =>
(Maybe ctx -> Maybe ctx) -> Store ctx -> m (Maybe ctx)
mineMayOnDefault Maybe ctx -> Maybe ctx
forall a. a -> a
id

mineMayOnDefault
  :: forall m ctx
   . (MonadIO m)
  => (Maybe ctx -> Maybe ctx)
  -> Store ctx
  -> m (Maybe ctx)
mineMayOnDefault :: (Maybe ctx -> Maybe ctx) -> Store ctx -> m (Maybe ctx)
mineMayOnDefault Maybe ctx -> Maybe ctx
onDefault Store { IORef (State ctx)
ref :: IORef (State ctx)
$sel:ref:Store :: forall ctx. Store ctx -> IORef (State ctx)
ref } = do
  ThreadId
threadId <- IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO ThreadId
Concurrent.myThreadId
  State { Map ThreadId [ctx]
stacks :: Map ThreadId [ctx]
$sel:stacks:State :: forall ctx. State ctx -> Map ThreadId [ctx]
stacks, Maybe ctx
def :: Maybe ctx
$sel:def:State :: forall ctx. State ctx -> Maybe ctx
def } <- IO (State ctx) -> m (State ctx)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (State ctx) -> m (State ctx))
-> IO (State ctx) -> m (State ctx)
forall a b. (a -> b) -> a -> b
$ IORef (State ctx) -> IO (State ctx)
forall a. IORef a -> IO a
IORef.readIORef IORef (State ctx)
ref
  Maybe ctx -> m (Maybe ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ctx -> m (Maybe ctx)) -> Maybe ctx -> m (Maybe ctx)
forall a b. (a -> b) -> a -> b
$ case ThreadId -> Map ThreadId [ctx] -> Maybe [ctx]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
threadId Map ThreadId [ctx]
stacks of
    Maybe [ctx]
Nothing -> Maybe ctx -> Maybe ctx
onDefault Maybe ctx
def
    Just [] -> String -> Maybe ctx
forall a. HasCallStack => String -> a
bug String
"mineMayOnDefault"
    Just (ctx
context : [ctx]
_rest) -> ctx -> Maybe ctx
forall a. a -> Maybe a
Just ctx
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
  :: forall m ctx a
   . (MonadIO m, MonadMask m)
  => Store ctx
  -> ctx
  -> m a
  -> m a
use :: Store ctx -> ctx -> m a -> m a
use Store ctx
store ctx
context =
  m () -> m () -> m a -> m a
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
Catch.bracket_ (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Store ctx -> ctx -> IO ()
forall ctx. Store ctx -> ctx -> IO ()
push Store ctx
store ctx
context) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Store ctx -> IO ()
forall ctx. Store ctx -> IO ()
pop Store ctx
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
  :: forall m ctx a
   . (MonadIO m, MonadMask m)
  => PropagationStrategy
  -- ^ The strategy used by "Context.Concurrent" for propagating context from a
  -- "parent" thread to a new thread.
  -> Maybe ctx
  -- ^ 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 -> m a)
  -> m a
withStore :: PropagationStrategy -> Maybe ctx -> (Store ctx -> m a) -> m a
withStore PropagationStrategy
propagationStrategy Maybe ctx
mContext Store ctx -> m a
f = do
  Store ctx
store <- PropagationStrategy -> Maybe ctx -> m (Store ctx)
forall (m :: * -> *) ctx.
MonadIO m =>
PropagationStrategy -> Maybe ctx -> m (Store ctx)
newStore PropagationStrategy
propagationStrategy Maybe ctx
mContext
  m a -> m () -> m a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
Catch.finally (Store ctx -> m a
f Store ctx
store) (m () -> m a) -> m () -> m a
forall a b. (a -> b) -> a -> b
$ do
    case PropagationStrategy
propagationStrategy of
      PropagationStrategy
NoPropagation -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      PropagationStrategy
LatestPropagation -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Registry -> Store ctx -> IO ()
forall ctx. Registry -> Store ctx -> IO ()
unregister Registry
registry Store ctx
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
  :: forall m ctx
   . (MonadIO m)
  => PropagationStrategy
  -- ^ The strategy used by "Context.Concurrent" for propagating context from a
  -- "parent" thread to a new thread.
  -> Maybe ctx
  -- ^ 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.
  -> m (Store ctx)
newStore :: PropagationStrategy -> Maybe ctx -> m (Store ctx)
newStore PropagationStrategy
propagationStrategy Maybe ctx
def = do
  Unique
key <- IO Unique -> m Unique
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Unique -> m Unique) -> IO Unique -> m Unique
forall a b. (a -> b) -> a -> b
$ IO Unique
Unique.newUnique
  IORef (State ctx)
ref <- IO (IORef (State ctx)) -> m (IORef (State ctx))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (State ctx)) -> m (IORef (State ctx)))
-> IO (IORef (State ctx)) -> m (IORef (State ctx))
forall a b. (a -> b) -> a -> b
$ State ctx -> IO (IORef (State ctx))
forall a. a -> IO (IORef a)
IORef.newIORef State :: forall ctx. Map ThreadId [ctx] -> Maybe ctx -> State ctx
State { $sel:stacks:State :: Map ThreadId [ctx]
stacks = Map ThreadId [ctx]
forall k a. Map k a
Map.empty, Maybe ctx
def :: Maybe ctx
$sel:def:State :: Maybe ctx
def }
  let store :: Store ctx
store = Store :: forall ctx. IORef (State ctx) -> Unique -> Store ctx
Store { IORef (State ctx)
ref :: IORef (State ctx)
$sel:ref:Store :: IORef (State ctx)
ref, Unique
key :: Unique
$sel:key:Store :: Unique
key }
  case PropagationStrategy
propagationStrategy of
    PropagationStrategy
NoPropagation -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PropagationStrategy
LatestPropagation -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Registry -> Store ctx -> IO ()
forall ctx. Registry -> Store ctx -> IO ()
register Registry
registry Store ctx
store
  Store ctx -> m (Store ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Store ctx
store

push :: Store ctx -> ctx -> IO ()
push :: Store ctx -> ctx -> IO ()
push Store { IORef (State ctx)
ref :: IORef (State ctx)
$sel:ref:Store :: forall ctx. Store ctx -> IORef (State ctx)
ref } ctx
context = do
  ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
  IORef (State ctx) -> (State ctx -> (State ctx, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (State ctx)
ref ((State ctx -> (State ctx, ())) -> IO ())
-> (State ctx -> (State ctx, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \state :: State ctx
state@State { Map ThreadId [ctx]
stacks :: Map ThreadId [ctx]
$sel:stacks:State :: forall ctx. State ctx -> Map ThreadId [ctx]
stacks } ->
    case ThreadId -> Map ThreadId [ctx] -> Maybe [ctx]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
threadId Map ThreadId [ctx]
stacks of
      Maybe [ctx]
Nothing ->
        (State ctx
state { $sel:stacks:State :: Map ThreadId [ctx]
stacks = ThreadId -> [ctx] -> Map ThreadId [ctx] -> Map ThreadId [ctx]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
threadId [ctx
context] Map ThreadId [ctx]
stacks }, ())
      Just [ctx]
contexts ->
        (State ctx
state { $sel:stacks:State :: Map ThreadId [ctx]
stacks = ThreadId -> [ctx] -> Map ThreadId [ctx] -> Map ThreadId [ctx]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
threadId (ctx
context ctx -> [ctx] -> [ctx]
forall a. a -> [a] -> [a]
: [ctx]
contexts) Map ThreadId [ctx]
stacks}, ())

pop :: Store ctx -> IO ()
pop :: Store ctx -> IO ()
pop Store { IORef (State ctx)
ref :: IORef (State ctx)
$sel:ref:Store :: forall ctx. Store ctx -> IORef (State ctx)
ref } = do
  ThreadId
threadId <- IO ThreadId
Concurrent.myThreadId
  IORef (State ctx) -> (State ctx -> (State ctx, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (State ctx)
ref ((State ctx -> (State ctx, ())) -> IO ())
-> (State ctx -> (State ctx, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \state :: State ctx
state@State { Map ThreadId [ctx]
stacks :: Map ThreadId [ctx]
$sel:stacks:State :: forall ctx. State ctx -> Map ThreadId [ctx]
stacks } ->
    case ThreadId -> Map ThreadId [ctx] -> Maybe [ctx]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
threadId Map ThreadId [ctx]
stacks of
      Maybe [ctx]
Nothing -> String -> (State ctx, ())
forall a. HasCallStack => String -> a
bug String
"pop-1"
      Just [] -> String -> (State ctx, ())
forall a. HasCallStack => String -> a
bug String
"pop-2"

      Just [ctx
_context] ->
        (State ctx
state { $sel:stacks:State :: Map ThreadId [ctx]
stacks = ThreadId -> Map ThreadId [ctx] -> Map ThreadId [ctx]
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ThreadId
threadId Map ThreadId [ctx]
stacks }, ())
      Just (ctx
_context : [ctx]
rest) ->
        (State ctx
state { $sel:stacks:State :: Map ThreadId [ctx]
stacks = ThreadId -> [ctx] -> Map ThreadId [ctx] -> Map ThreadId [ctx]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
threadId [ctx]
rest Map ThreadId [ctx]
stacks }, ())

-- | A 'Context.View.View' provides a read-only view into a 'Context.Store'.
-- 'Context.View.View' trades the 'Context.Store' ability to register new
-- context for the ability to arbitrarily transform context values locally to
-- the 'Context.View.View'.
--
-- @since 0.1.1.0
data View ctx where
  MkView :: (ctx' -> ctx) -> Store ctx' -> View ctx

instance Functor View where
  fmap :: (a -> b) -> View a -> View b
fmap a -> b
g (MkView ctx' -> a
f Store ctx'
store) = (ctx' -> b) -> Store ctx' -> View b
forall ctx' ctx. (ctx' -> ctx) -> Store ctx' -> View ctx
MkView (a -> b
g (a -> b) -> (ctx' -> a) -> ctx' -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx' -> a
f) Store ctx'
store

-- | Provide the calling thread a view of its current context from the specified
-- 'Context.View.View'. Throws a 'Context.NotFoundException' when the calling
-- thread has no registered context.
--
-- @since 0.1.1.0
view :: (MonadIO m, MonadThrow m) => View ctx -> m ctx
view :: View ctx -> m ctx
view = m ctx -> (ctx -> m ctx) -> Maybe ctx -> m ctx
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m ctx
forall (m :: * -> *) a. (MonadIO m, MonadThrow m) => m a
throwContextNotFound ctx -> m ctx
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ctx -> m ctx)
-> (View ctx -> m (Maybe ctx)) -> View ctx -> m ctx
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< View ctx -> m (Maybe ctx)
forall (m :: * -> *) ctx. MonadIO m => View ctx -> m (Maybe ctx)
viewMay

-- | Provide the calling thread a view of its current context from the specified
-- 'Context.View.View', if present.
--
-- @since 0.1.1.0
viewMay :: (MonadIO m) => View ctx -> m (Maybe ctx)
viewMay :: View ctx -> m (Maybe ctx)
viewMay = \case
  MkView ctx' -> ctx
f Store ctx'
store -> (Maybe ctx' -> Maybe ctx) -> m (Maybe ctx') -> m (Maybe ctx)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ctx' -> ctx) -> Maybe ctx' -> Maybe ctx
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ctx' -> ctx
f) (m (Maybe ctx') -> m (Maybe ctx))
-> m (Maybe ctx') -> m (Maybe ctx)
forall a b. (a -> b) -> a -> b
$ Store ctx' -> m (Maybe ctx')
forall (m :: * -> *) ctx. MonadIO m => Store ctx -> m (Maybe ctx)
mineMay Store ctx'
store

-- | Create a 'Context.View.View' from the provided 'Context.Store'.
--
-- @since 0.1.1.0
toView :: Store ctx -> View ctx
toView :: Store ctx -> View ctx
toView = (ctx -> ctx) -> Store ctx -> View ctx
forall ctx' ctx. (ctx' -> ctx) -> Store ctx' -> View ctx
MkView ctx -> ctx
forall a. a -> a
id

data AnyStore where
  MkAnyStore :: forall ctx. Store ctx -> AnyStore

newtype Registry = Registry
  { Registry -> IORef (Map Unique AnyStore)
ref :: IORef (Map Unique AnyStore)
  }

registry :: Registry
registry :: Registry
registry = IO Registry -> Registry
forall a. IO a -> a
unsafePerformIO IO Registry
emptyRegistry
{-# NOINLINE registry #-}

emptyRegistry :: IO Registry
emptyRegistry :: IO Registry
emptyRegistry = do
  IORef (Map Unique AnyStore)
ref <- Map Unique AnyStore -> IO (IORef (Map Unique AnyStore))
forall a. a -> IO (IORef a)
IORef.newIORef Map Unique AnyStore
forall k a. Map k a
Map.empty
  Registry -> IO Registry
forall (f :: * -> *) a. Applicative f => a -> f a
pure Registry :: IORef (Map Unique AnyStore) -> Registry
Registry { IORef (Map Unique AnyStore)
ref :: IORef (Map Unique AnyStore)
$sel:ref:Registry :: IORef (Map Unique AnyStore)
ref }

withPropagator :: ((IO a -> IO a) -> IO b) -> IO b
withPropagator :: ((IO a -> IO a) -> IO b) -> IO b
withPropagator = Registry -> ((IO a -> IO a) -> IO b) -> IO b
forall a b. Registry -> ((IO a -> IO a) -> IO b) -> IO b
withRegisteredPropagator Registry
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 -> ((IO a -> IO a) -> IO b) -> IO b
withRegisteredPropagator Registry { IORef (Map Unique AnyStore)
ref :: IORef (Map Unique AnyStore)
$sel:ref:Registry :: Registry -> IORef (Map Unique AnyStore)
ref } (IO a -> IO a) -> IO b
f = do
  Map Unique AnyStore
stores <- IORef (Map Unique AnyStore) -> IO (Map Unique AnyStore)
forall a. IORef a -> IO a
IORef.readIORef IORef (Map Unique AnyStore)
ref
  IO a -> IO a
propagator <- do
    (Map Unique (IO a -> IO a) -> IO a -> IO a)
-> IO (Map Unique (IO a -> IO a)) -> IO (IO a -> IO a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a)
-> (IO a -> IO a) -> Map Unique (IO a -> IO a) -> IO a -> IO a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (IO a -> IO a) -> (IO a -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) IO a -> IO a
forall a. a -> a
id) (IO (Map Unique (IO a -> IO a)) -> IO (IO a -> IO a))
-> IO (Map Unique (IO a -> IO a)) -> IO (IO a -> IO a)
forall a b. (a -> b) -> a -> b
$ do
      Map Unique AnyStore
-> (AnyStore -> IO (IO a -> IO a))
-> IO (Map Unique (IO a -> IO a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
Traversable.for Map Unique AnyStore
stores ((AnyStore -> IO (IO a -> IO a)) -> IO (Map Unique (IO a -> IO a)))
-> (AnyStore -> IO (IO a -> IO a))
-> IO (Map Unique (IO a -> IO a))
forall a b. (a -> b) -> a -> b
$ \case
        MkAnyStore Store ctx
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.
          (Maybe ctx -> Maybe ctx) -> Store ctx -> IO (Maybe ctx)
forall (m :: * -> *) ctx.
MonadIO m =>
(Maybe ctx -> Maybe ctx) -> Store ctx -> m (Maybe ctx)
mineMayOnDefault (Maybe ctx -> Maybe ctx -> Maybe ctx
forall a b. a -> b -> a
const Maybe ctx
forall a. Maybe a
Nothing) Store ctx
store IO (Maybe ctx)
-> (Maybe ctx -> IO (IO a -> IO a)) -> IO (IO a -> IO a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe ctx
Nothing -> (IO a -> IO a) -> IO (IO a -> IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure IO a -> IO a
forall a. a -> a
id
            Just ctx
context -> (IO a -> IO a) -> IO (IO a -> IO a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((IO a -> IO a) -> IO (IO a -> IO a))
-> (IO a -> IO a) -> IO (IO a -> IO a)
forall a b. (a -> b) -> a -> b
$ Store ctx -> ctx -> IO a -> IO a
forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
Store ctx -> ctx -> m a -> m a
use Store ctx
store ctx
context
  (IO a -> IO a) -> IO b
f IO a -> IO a
propagator

register :: Registry -> Store ctx -> IO ()
register :: Registry -> Store ctx -> IO ()
register Registry { IORef (Map Unique AnyStore)
ref :: IORef (Map Unique AnyStore)
$sel:ref:Registry :: Registry -> IORef (Map Unique AnyStore)
ref } store :: Store ctx
store@Store { Unique
key :: Unique
$sel:key:Store :: forall ctx. Store ctx -> Unique
key } = do
  IORef (Map Unique AnyStore)
-> (Map Unique AnyStore -> (Map Unique AnyStore, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (Map Unique AnyStore)
ref ((Map Unique AnyStore -> (Map Unique AnyStore, ())) -> IO ())
-> (Map Unique AnyStore -> (Map Unique AnyStore, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Unique AnyStore
stores ->
    (Unique -> AnyStore -> Map Unique AnyStore -> Map Unique AnyStore
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unique
key (Store ctx -> AnyStore
forall ctx. Store ctx -> AnyStore
MkAnyStore Store ctx
store) Map Unique AnyStore
stores, ())

unregister :: Registry -> Store ctx -> IO ()
unregister :: Registry -> Store ctx -> IO ()
unregister Registry { IORef (Map Unique AnyStore)
ref :: IORef (Map Unique AnyStore)
$sel:ref:Registry :: Registry -> IORef (Map Unique AnyStore)
ref } Store { Unique
key :: Unique
$sel:key:Store :: forall ctx. Store ctx -> Unique
key } = do
  IORef (Map Unique AnyStore)
-> (Map Unique AnyStore -> (Map Unique AnyStore, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (Map Unique AnyStore)
ref ((Map Unique AnyStore -> (Map Unique AnyStore, ())) -> IO ())
-> (Map Unique AnyStore -> (Map Unique AnyStore, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Map Unique AnyStore
stores ->
    (Unique -> Map Unique AnyStore -> Map Unique AnyStore
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Unique
key Map Unique AnyStore
stores, ())

bug :: HasCallStack => String -> a
bug :: String -> a
bug String
prefix =
  String -> a
forall a. HasCallStack => String -> a
error
    (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Context." String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
prefix String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": Impossible! (if you see this message, please "
        String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"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.