{-# 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
{ forall ctx. Store ctx -> IORef (State ctx)
ref :: IORef (State ctx)
, forall ctx. Store ctx -> Unique
key :: Unique
}
data State ctx = State
{ forall ctx. State ctx -> Map ThreadId [ctx]
stacks :: Map ThreadId [ctx]
, forall ctx. State ctx -> Maybe ctx
def :: Maybe ctx
}
data NotFoundException = NotFoundException
{ NotFoundException -> ThreadId
threadId :: ThreadId
} deriving stock (NotFoundException -> NotFoundException -> Bool
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. 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
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
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
Exception
data PropagationStrategy
= NoPropagation
| LatestPropagation
setDefault
:: forall m ctx
. (MonadIO m)
=> Store ctx
-> ctx
-> m ()
setDefault :: forall (m :: * -> *) ctx. MonadIO m => 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
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (State ctx)
ref forall a b. (a -> b) -> a -> b
$ \State ctx
state ->
(State ctx
state { $sel:def:State :: Maybe ctx
def = forall a. a -> Maybe a
Just ctx
context }, ())
throwContextNotFound
:: forall m a
. (MonadIO m, MonadThrow m)
=> m a
throwContextNotFound :: forall (m :: * -> *) a. (MonadIO m, MonadThrow m) => m a
throwContextNotFound = do
ThreadId
threadId <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO ThreadId
Concurrent.myThreadId
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
Catch.throwM forall a b. (a -> b) -> a -> b
$ NotFoundException { ThreadId
threadId :: ThreadId
$sel:threadId:NotFoundException :: ThreadId
threadId }
mineMay
:: forall m ctx
. (MonadIO m)
=> Store ctx
-> m (Maybe ctx)
mineMay :: forall (m :: * -> *) ctx. MonadIO m => Store ctx -> m (Maybe ctx)
mineMay = forall (m :: * -> *) ctx.
MonadIO m =>
(Maybe ctx -> Maybe ctx) -> Store ctx -> m (Maybe ctx)
mineMayOnDefault forall a. a -> a
id
mineMayOnDefault
:: forall m ctx
. (MonadIO m)
=> (Maybe ctx -> Maybe ctx)
-> Store ctx
-> m (Maybe ctx)
mineMayOnDefault :: forall (m :: * -> *) ctx.
MonadIO m =>
(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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 } <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
IORef.readIORef IORef (State ctx)
ref
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case 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 [] -> forall a. HasCallStack => String -> a
bug String
"mineMayOnDefault"
Just (ctx
context : [ctx]
_rest) -> 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 :: forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
Store ctx -> ctx -> m a -> m a
use Store ctx
store ctx
context =
forall (m :: * -> *) a c b. MonadMask m => m a -> m c -> m b -> m b
Catch.bracket_ (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall ctx. Store ctx -> ctx -> IO ()
push Store ctx
store ctx
context) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
PropagationStrategy -> Maybe ctx -> (Store ctx -> m a) -> m a
withStore PropagationStrategy
propagationStrategy Maybe ctx
mContext Store ctx -> m a
f = do
Store ctx
store <- forall (m :: * -> *) ctx.
MonadIO m =>
PropagationStrategy -> Maybe ctx -> m (Store ctx)
newStore PropagationStrategy
propagationStrategy Maybe ctx
mContext
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
Catch.finally (Store ctx -> m a
f Store ctx
store) forall a b. (a -> b) -> a -> b
$ do
case PropagationStrategy
propagationStrategy of
PropagationStrategy
NoPropagation -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
PropagationStrategy
LatestPropagation -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ 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 :: forall (m :: * -> *) ctx.
MonadIO m =>
PropagationStrategy -> Maybe ctx -> m (Store ctx)
newStore PropagationStrategy
propagationStrategy Maybe ctx
def = do
Unique
key <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO Unique
Unique.newUnique
IORef (State ctx)
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
IORef.newIORef State { $sel:stacks:State :: Map ThreadId [ctx]
stacks = 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 { 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
PropagationStrategy
LatestPropagation -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall ctx. Registry -> Store ctx -> IO ()
register Registry
registry Store ctx
store
forall (f :: * -> *) a. Applicative f => a -> f a
pure Store ctx
store
push :: Store ctx -> ctx -> IO ()
push :: forall ctx. 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
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (State ctx)
ref 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 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 = 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 = forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
threadId (ctx
context forall a. a -> [a] -> [a]
: [ctx]
contexts) Map ThreadId [ctx]
stacks}, ())
pop :: Store ctx -> IO ()
pop :: forall ctx. 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
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (State ctx)
ref 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 forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ThreadId
threadId Map ThreadId [ctx]
stacks of
Maybe [ctx]
Nothing -> forall a. HasCallStack => String -> a
bug String
"pop-1"
Just [] -> forall a. HasCallStack => String -> a
bug String
"pop-2"
Just [ctx
_context] ->
(State ctx
state { $sel:stacks:State :: Map ThreadId [ctx]
stacks = 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 = 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 :: forall a b. (a -> b) -> View a -> View b
fmap a -> b
g (MkView ctx' -> a
f Store ctx'
store) = forall ctx ctx. (ctx -> ctx) -> Store ctx -> View ctx
MkView (a -> b
g 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 :: forall (m :: * -> *) ctx.
(MonadIO m, MonadThrow m) =>
View ctx -> m ctx
view = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall (m :: * -> *) a. (MonadIO m, MonadThrow m) => m a
throwContextNotFound forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) ctx. MonadIO m => View ctx -> m (Maybe ctx)
viewMay
viewMay :: (MonadIO m) => View ctx -> m (Maybe ctx)
viewMay :: forall (m :: * -> *) ctx. MonadIO m => View ctx -> m (Maybe ctx)
viewMay = \case
MkView ctx' -> ctx
f Store ctx'
store -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ctx' -> ctx
f) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) ctx. MonadIO m => Store ctx -> m (Maybe ctx)
mineMay Store ctx'
store
toView :: Store ctx -> View ctx
toView :: forall ctx. Store ctx -> View ctx
toView = forall ctx ctx. (ctx -> ctx) -> Store ctx -> View ctx
MkView 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 = forall a. IO a -> a
unsafePerformIO IO Registry
emptyRegistry
{-# NOINLINE registry #-}
emptyRegistry :: IO Registry
emptyRegistry :: IO Registry
emptyRegistry = do
IORef (Map Unique AnyStore)
ref <- forall a. a -> IO (IORef a)
IORef.newIORef forall k a. Map k a
Map.empty
forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 :: forall a b. ((IO a -> IO a) -> IO b) -> IO b
withPropagator = 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 :: forall a b. 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 <- forall a. IORef a -> IO a
IORef.readIORef IORef (Map Unique AnyStore)
ref
IO a -> IO a
propagator <- do
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
Traversable.for Map Unique AnyStore
stores forall a b. (a -> b) -> a -> b
$ \case
MkAnyStore Store ctx
store -> do
forall (m :: * -> *) ctx.
MonadIO m =>
(Maybe ctx -> Maybe ctx) -> Store ctx -> m (Maybe ctx)
mineMayOnDefault (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) Store ctx
store forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe ctx
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. a -> a
id
Just ctx
context -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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 :: forall ctx. 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
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (Map Unique AnyStore)
ref forall a b. (a -> b) -> a -> b
$ \Map Unique AnyStore
stores ->
(forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Unique
key (forall ctx. Store ctx -> AnyStore
MkAnyStore Store ctx
store) Map Unique AnyStore
stores, ())
unregister :: Registry -> Store ctx -> IO ()
unregister :: forall ctx. 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
forall a b. IORef a -> (a -> (a, b)) -> IO b
IORef.atomicModifyIORef' IORef (Map Unique AnyStore)
ref forall a b. (a -> b) -> a -> b
$ \Map Unique AnyStore
stores ->
(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 :: forall a. HasCallStack => String -> a
bug String
prefix =
forall a. HasCallStack => String -> a
error
forall a b. (a -> b) -> a -> b
$ String
"Context." forall a. Semigroup a => a -> a -> a
<> String
prefix forall a. Semigroup a => a -> a -> a
<> String
": Impossible! (if you see this message, please "
forall a. Semigroup a => a -> a -> a
<> String
"report it as a bug at https://github.com/jship/context)"