module Graphics.Caramia.Internal.ContextLocalData where
import Control.Concurrent
import Control.Monad.IO.Class
import Data.Dynamic
import Graphics.Caramia.Prelude
import qualified Data.IntMap.Strict as IM
import qualified Data.Map.Strict as M
import System.IO.Unsafe
newtype ContextID = ContextID Int
deriving ( Eq, Ord, Show, Typeable )
nextContextID :: IORef ContextID
nextContextID = unsafePerformIO $ newIORef $ ContextID 0
newContextID :: IO ContextID
newContextID = atomicModifyIORef' nextContextID $ \(ContextID old) ->
( ContextID $ old+1, ContextID old )
runningContexts :: IORef (M.Map ThreadId ContextID)
runningContexts = unsafePerformIO $ newIORef M.empty
contextLocalData :: IORef (IM.IntMap (M.Map TypeRep Dynamic))
contextLocalData = unsafePerformIO $ newIORef IM.empty
currentContextID :: MonadIO m => m (Maybe ContextID)
currentContextID =
liftIO $ M.lookup <$> myThreadId <*> readIORef runningContexts
storeContextLocalData :: (MonadIO m, Typeable a) => a -> m ()
storeContextLocalData value =
liftIO $ maybe (error "storeContextLocalData: not in a context.")
(\(ContextID cid) ->
atomicModifyIORef' contextLocalData $ \old ->
( IM.alter (Just . maybe (M.singleton
(typeOf value)
(toDyn value))
(M.insert (typeOf value)
(toDyn value)))
cid
old
, () ) )
=<< currentContextID
retrieveContextLocalData :: forall m a. (MonadIO m, Typeable a)
=> m a
-> m a
retrieveContextLocalData defvalue =
maybe (error "retrieveContextLocalData: not in a context.")
(\(ContextID cid) -> do
snapshot <- liftIO $ readIORef contextLocalData
case IM.lookup cid snapshot of
Nothing -> do
val <- dyndefvalue
liftIO $ atomicModifyIORef' contextLocalData $ \old ->
( IM.insert cid (M.singleton typ val) old
, fromDyn val undefined )
Just old_map ->
case M.lookup typ old_map of
Nothing -> do
val <- dyndefvalue
liftIO $ atomicModifyIORef' contextLocalData $ \old ->
( IM.adjust (M.insert typ val)
cid
old
, fromDyn val undefined )
Just value -> return (fromDyn value undefined))
=<< liftIO currentContextID
where
typ = typeOf (undefined :: a)
dyndefvalue = defvalue >>= return . toDyn