{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Context
  ( -- * Introduction
    -- $intro

    -- * Storage
    Store
  , withNonEmptyStore
  , withEmptyStore

    -- * Operations
    -- ** Registering context
  , use
  , adjust
  , withAdjusted

    -- ** Asking for context
  , mine
  , mines

  , mineMay
  , minesMay

    -- * Views
  , module Context.View

    -- * Exceptions
  , NotFoundException(NotFoundException, threadId)

    -- * Concurrency
  , module Context.Concurrent

    -- * Lower-level storage
  , module Context.Storage
  ) where

import Context.Concurrent
import Context.Internal (NotFoundException(NotFoundException, threadId), Store, mineMay, use)
import Context.Storage
import Context.View
import Control.Monad ((<=<))
import Control.Monad.Catch (MonadMask, MonadThrow)
import Control.Monad.IO.Class (MonadIO)
import Prelude
import qualified Context.Internal as Internal

-- | 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
  :: forall m ctx a
   . (MonadIO m, MonadMask m)
  => ctx
  -> (Store ctx -> m a)
  -> m a
withNonEmptyStore :: forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
ctx -> (Store ctx -> m a) -> m a
withNonEmptyStore = PropagationStrategy -> Maybe ctx -> (Store ctx -> m a) -> m a
forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
PropagationStrategy -> Maybe ctx -> (Store ctx -> m a) -> m a
Internal.withStore PropagationStrategy
defaultPropagation (Maybe ctx -> (Store ctx -> m a) -> m a)
-> (ctx -> Maybe ctx) -> ctx -> (Store ctx -> m a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ctx -> Maybe ctx
forall a. a -> Maybe a
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
  :: forall m ctx a
   . (MonadIO m, MonadMask m)
  => (Store ctx -> m a)
  -> m a
withEmptyStore :: forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
(Store ctx -> m a) -> m a
withEmptyStore = PropagationStrategy -> Maybe ctx -> (Store ctx -> m a) -> m a
forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
PropagationStrategy -> Maybe ctx -> (Store ctx -> m a) -> m a
Internal.withStore PropagationStrategy
defaultPropagation Maybe ctx
forall a. Maybe a
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
  :: forall m ctx a
   . (MonadIO m, MonadMask m)
  => Store ctx
  -> (ctx -> ctx)
  -> m a
  -> m a
adjust :: forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
Store ctx -> (ctx -> ctx) -> m a -> m a
adjust Store ctx
store ctx -> ctx
f m a
action = Store ctx -> (ctx -> ctx) -> (ctx -> m a) -> m a
forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
Store ctx -> (ctx -> ctx) -> (ctx -> m a) -> m a
withAdjusted Store ctx
store ctx -> ctx
f ((ctx -> m a) -> m a) -> (ctx -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ m a -> ctx -> m a
forall a b. a -> b -> a
const m a
action

-- | Convenience function to 'adjust' the context then supply the adjusted
-- context to the inner action. This function is equivalent to calling 'adjust'
-- and then immediately calling 'mine' in the inner action of 'adjust', e.g.:
--
-- > doStuff :: Store Thing -> (Thing -> Thing) -> IO ()
-- > doStuff store f = do
-- >   adjust store f do
-- >     adjustedThing <- mine store
-- >     ...
--
-- Throws a 'NotFoundException' when the calling thread has no registered
-- context.
--
-- @since 0.2.0.0
withAdjusted
  :: forall m ctx a
   . (MonadIO m, MonadMask m)
  => Store ctx
  -> (ctx -> ctx)
  -> (ctx -> m a)
  -> m a
withAdjusted :: forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
Store ctx -> (ctx -> ctx) -> (ctx -> m a) -> m a
withAdjusted Store ctx
store ctx -> ctx
f ctx -> m a
action = do
  ctx
adjustedContext <- Store ctx -> (ctx -> ctx) -> m ctx
forall (m :: * -> *) ctx a.
(MonadIO m, MonadThrow m) =>
Store ctx -> (ctx -> a) -> m a
mines Store ctx
store ctx -> ctx
f
  Store ctx -> ctx -> m a -> m a
forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
Store ctx -> ctx -> m a -> m a
use Store ctx
store ctx
adjustedContext (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ ctx -> m a
action ctx
adjustedContext

-- | 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
  :: forall m ctx
   . (MonadIO m, MonadThrow m)
  => Store ctx
  -> m ctx
mine :: forall (m :: * -> *) ctx.
(MonadIO m, MonadThrow m) =>
Store ctx -> m ctx
mine = 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
Internal.throwContextNotFound ctx -> m ctx
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ctx -> m ctx)
-> (Store ctx -> m (Maybe ctx)) -> Store ctx -> m ctx
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Store ctx -> m (Maybe ctx)
forall (m :: * -> *) ctx. MonadIO m => Store ctx -> m (Maybe ctx)
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
  :: forall m ctx a
   . (MonadIO m, MonadThrow m)
  => Store ctx
  -> (ctx -> a)
  -> m a
mines :: forall (m :: * -> *) ctx a.
(MonadIO m, MonadThrow m) =>
Store ctx -> (ctx -> a) -> m a
mines Store ctx
store = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe m a
forall (m :: * -> *) a. (MonadIO m, MonadThrow m) => m a
Internal.throwContextNotFound a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> m a)
-> ((ctx -> a) -> m (Maybe a)) -> (ctx -> a) -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Store ctx -> (ctx -> a) -> m (Maybe a)
forall (m :: * -> *) ctx a.
MonadIO m =>
Store ctx -> (ctx -> a) -> m (Maybe a)
minesMay Store ctx
store

-- | Provide the calling thread a selection from its current context in the
-- specified 'Store', if present.
--
-- @since 0.1.0.0
minesMay
  :: forall m ctx a
   . (MonadIO m)
  => Store ctx
  -> (ctx -> a)
  -> m (Maybe a)
minesMay :: forall (m :: * -> *) ctx a.
MonadIO m =>
Store ctx -> (ctx -> a) -> m (Maybe a)
minesMay Store ctx
store ctx -> a
selector = (Maybe ctx -> Maybe a) -> m (Maybe ctx) -> m (Maybe a)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ctx -> a) -> Maybe ctx -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ctx -> a
selector) (m (Maybe ctx) -> m (Maybe a)) -> m (Maybe ctx) -> m (Maybe a)
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

-- $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