{-# 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
(
Store(Store, ref, key)
, State(State, stacks, def)
, NotFoundException(NotFoundException, threadId)
, withStore
, newStore
, use
, push
, pop
, mineMay
, mineMayOnDefault
, setDefault
, throwContextNotFound
, View(MkView)
, view
, viewMay
, toView
, PropagationStrategy(NoPropagation, LatestPropagation)
, Registry(Registry, ref)
, AnyStore(MkAnyStore)
, registry
, emptyRegistry
, withPropagator
, withRegisteredPropagator
, register
, unregister
, 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
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
}
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
data PropagationStrategy
= NoPropagation
| LatestPropagation
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 }
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
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)
withStore
:: forall m ctx a
. (MonadIO m, MonadMask m)
=> PropagationStrategy
-> Maybe ctx
-> (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
newStore
:: forall m ctx
. (MonadIO m)
=> PropagationStrategy
-> Maybe ctx
-> 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 }, ())
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
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
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
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
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
(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)"