{-# LANGUAGE ImplicitParams #-}
-- | Turn an effect handler into an effectful operation.
--
-- @since 2.3.0.0
module Effectful.Provider
  ( -- * Example
    -- $example

    -- * Effect
    Provider
  , Provider_

    -- ** Handlers
  , runProvider
  , runProvider_

    -- ** Operations
  , provide
  , provide_
  , provideWith
  , provideWith_
  ) where

import Control.Monad
import Data.Coerce
import Data.Functor.Identity
import Data.Kind (Type)
import Data.Primitive.PrimArray
import GHC.Stack

import Effectful
import Effectful.Dispatch.Static
import Effectful.Dispatch.Static.Primitive
import Effectful.Internal.Env (Env(..))
import Effectful.Internal.Utils

-- $example
--
-- >>> import Control.Monad.IO.Class
-- >>> import Data.Map.Strict qualified as M
-- >>> import Effectful.Dispatch.Dynamic
-- >>> import Effectful.State.Static.Local
--
-- Given an effect:
--
-- >>> :{
--   data Write :: Effect where
--     Write :: String -> Write m ()
--   type instance DispatchOf Write = Dynamic
-- :}
--
-- >>> :{
--   write :: Write :> es => String -> Eff es ()
--   write = send . Write
-- :}
--
-- its handler can be turned into an effectful operation with the 'Provider'
-- effect:
--
-- >>> :{
--   action :: Provider_ Write FilePath :> es => Eff es ()
--   action = do
--     provideWith_ @Write "in.txt" $ do
--       write "hi"
--       write "there"
--     provideWith_ @Write "out.txt" $ do
--       write "good"
--       write "bye"
-- :}
--
-- Then, given multiple interpreters:
--
-- >>> :{
--   runWriteIO
--     :: IOE :> es
--     => FilePath
--     -> Eff (Write : es) a
--     -> Eff es a
--   runWriteIO fp = interpret_ $ \case
--     Write msg -> liftIO . putStrLn $ fp ++ ": " ++ msg
-- :}
--
-- >>> :{
--   runWritePure
--     :: State (M.Map FilePath [String]) :> es
--     => FilePath
--     -> Eff (Write : es) a
--     -> Eff es a
--   runWritePure fp = interpret_ $ \case
--     Write msg -> modify $ M.insertWith (++) fp [msg]
-- :}
--
-- @action@ can be supplied with either of them for the appropriate behavior:
--
-- >>> :{
--   runEff
--     . runProvider_ runWriteIO
--     $ action
-- :}
-- in.txt: hi
-- in.txt: there
-- out.txt: good
-- out.txt: bye
--
-- >>> :{
--   runPureEff
--     . fmap (fmap reverse)
--     . execState @(M.Map FilePath [String]) M.empty
--     . runProvider_ runWritePure
--     $ action
-- :}
-- fromList [("in.txt",["hi","there"]),("out.txt",["good","bye"])]

-- | Provide a way to run a handler of @e@ with a given @input@.
--
-- /Note:/ @f@ can be used to alter the return type of the effect handler. If
-- that's unnecessary, use 'Provider_'.
data Provider (e :: Effect) (input :: Type) (f :: Type -> Type) :: Effect

-- | A restricted variant of 'Provider' with unchanged return type of the effect
-- handler.
type Provider_ e input = Provider e input Identity

type instance DispatchOf (Provider e input f) = Static NoSideEffects

data instance StaticRep (Provider e input f) where
  Provider
    :: !(Env handlerEs)
    -> !(forall r. HasCallStack => input -> Eff (e : handlerEs) r -> Eff handlerEs (f r))
    -> StaticRep (Provider e input f)

-- | Run the 'Provider' effect with a given effect handler.
runProvider
  :: HasCallStack
  => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))
  -- ^ The effect handler.
  -> Eff (Provider e input f : es) a
  -> Eff es a
runProvider :: forall input (e :: Effect) (es :: [Effect]) (f :: Type -> Type) a.
HasCallStack =>
(forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))
-> Eff (Provider e input f : es) a -> Eff es a
runProvider forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r)
provider Eff (Provider e input f : es) a
m = (Env es -> IO a) -> Eff es a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO a) -> Eff es a) -> (Env es -> IO a) -> Eff es a
forall a b. (a -> b) -> a -> b
$ \Env es
es0 -> do
  IO (Env (Provider e input f : es))
-> (Env (Provider e input f : es) -> IO ())
-> (Env (Provider e input f : es) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
inlineBracket
    (EffectRep (DispatchOf (Provider e input f)) (Provider e input f)
-> Relinker
     (EffectRep (DispatchOf (Provider e input f))) (Provider e input f)
-> Env es
-> IO (Env (Provider e input f : es))
forall (e :: Effect) (es :: [Effect]).
HasCallStack =>
EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> Env es
-> IO (Env (e : es))
consEnv (Env es -> StaticRep (Provider e input f)
mkProvider Env es
es0) Relinker
  (EffectRep (DispatchOf (Provider e input f))) (Provider e input f)
Relinker StaticRep (Provider e input f)
forall (e :: Effect) input (f :: Type -> Type).
Relinker StaticRep (Provider e input f)
relinkProvider Env es
es0)
    Env (Provider e input f : es) -> IO ()
forall (e :: Effect) (es :: [Effect]).
HasCallStack =>
Env (e : es) -> IO ()
unconsEnv
    (\Env (Provider e input f : es)
es -> Eff (Provider e input f : es) a
-> Env (Provider e input f : es) -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff (Provider e input f : es) a
m Env (Provider e input f : es)
es)
  where
    -- Corresponds to withFrozenCallStack in provideWith.
    mkProvider :: Env es -> StaticRep (Provider e input f)
mkProvider Env es
es = Env es
-> (forall r.
    HasCallStack =>
    input -> Eff (e : es) r -> Eff es (f r))
-> StaticRep (Provider e input f)
forall (handlerEs :: [Effect]) input (e :: Effect)
       (f :: Type -> Type).
Env handlerEs
-> (forall r.
    HasCallStack =>
    input -> Eff (e : handlerEs) r -> Eff handlerEs (f r))
-> StaticRep (Provider e input f)
Provider Env es
es (let ?callStack = CallStack -> CallStack
thawCallStack HasCallStack
CallStack
?callStack in input -> Eff (e : es) r -> Eff es (f r)
forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r)
provider)

-- | Run the 'Provider' effect with a given effect handler that doesn't change
-- its return type.
runProvider_
  :: HasCallStack
  => (forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r)
  -- ^ The effect handler.
  -> Eff (Provider_ e input : es) a
  -> Eff es a
runProvider_ :: forall input (e :: Effect) (es :: [Effect]) a.
HasCallStack =>
(forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r)
-> Eff (Provider_ e input : es) a -> Eff es a
runProvider_ forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r
provider = (forall r.
 HasCallStack =>
 input -> Eff (e : es) r -> Eff es (Identity r))
-> Eff (Provider e input Identity : es) a -> Eff es a
forall input (e :: Effect) (es :: [Effect]) (f :: Type -> Type) a.
HasCallStack =>
(forall r. HasCallStack => input -> Eff (e : es) r -> Eff es (f r))
-> Eff (Provider e input f : es) a -> Eff es a
runProvider ((forall r.
  HasCallStack =>
  input -> Eff (e : es) r -> Eff es (Identity r))
 -> Eff (Provider e input Identity : es) a -> Eff es a)
-> (forall r.
    HasCallStack =>
    input -> Eff (e : es) r -> Eff es (Identity r))
-> Eff (Provider e input Identity : es) a
-> Eff es a
forall a b. (a -> b) -> a -> b
$ \input
input -> Eff es r -> Eff es (Identity r)
forall a b. Coercible a b => a -> b
coerce (Eff es r -> Eff es (Identity r))
-> (Eff (e : es) r -> Eff es r)
-> Eff (e : es) r
-> Eff es (Identity r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Eff (e : es) r -> Eff es r
forall r. HasCallStack => input -> Eff (e : es) r -> Eff es r
provider input
input

-- | Run the effect handler.
provide :: (HasCallStack, Provider e () f :> es) => Eff (e : es) a -> Eff es (f a)
provide :: forall (e :: Effect) (f :: Type -> Type) (es :: [Effect]) a.
(HasCallStack, Provider e () f :> es) =>
Eff (e : es) a -> Eff es (f a)
provide = () -> Eff (e : es) a -> Eff es (f a)
forall (e :: Effect) input (f :: Type -> Type) (es :: [Effect]) a.
(HasCallStack, Provider e input f :> es) =>
input -> Eff (e : es) a -> Eff es (f a)
provideWith ()

-- | Run the effect handler with unchanged return type.
provide_ :: (HasCallStack, Provider_ e () :> es) => Eff (e : es) a -> Eff es a
provide_ :: forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, Provider_ e () :> es) =>
Eff (e : es) a -> Eff es a
provide_ = () -> Eff (e : es) a -> Eff es a
forall (e :: Effect) input (es :: [Effect]) a.
(HasCallStack, Provider_ e input :> es) =>
input -> Eff (e : es) a -> Eff es a
provideWith_ ()

-- | Run the effect handler with a given input.
provideWith
  :: (HasCallStack, Provider e input f :> es)
  => input
  -- ^ The input to the effect handler.
  -> Eff (e : es) a
  -> Eff es (f a)
provideWith :: forall (e :: Effect) input (f :: Type -> Type) (es :: [Effect]) a.
(HasCallStack, Provider e input f :> es) =>
input -> Eff (e : es) a -> Eff es (f a)
provideWith input
input Eff (e : es) a
action = (Env es -> IO (f a)) -> Eff es (f a)
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO (f a)) -> Eff es (f a))
-> (Env es -> IO (f a)) -> Eff es (f a)
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  Provider Env handlerEs
handlerEs forall r.
HasCallStack =>
input -> Eff (e : handlerEs) r -> Eff handlerEs (f r)
handler <- Env es
-> IO
     (EffectRep (DispatchOf (Provider e input f)) (Provider e input f))
forall (e :: Effect) (es :: [Effect]).
(HasCallStack, e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv Env es
es
  (Eff handlerEs (f a) -> Env handlerEs -> IO (f a)
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env handlerEs
handlerEs)
    -- Corresponds to thawCallStack in runProvider.
    (Eff handlerEs (f a) -> IO (f a))
-> ((Env (e : handlerEs) -> IO a) -> Eff handlerEs (f a))
-> (Env (e : handlerEs) -> IO a)
-> IO (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HasCallStack =>
 input -> Eff (e : handlerEs) a -> Eff handlerEs (f a))
-> input -> Eff (e : handlerEs) a -> Eff handlerEs (f a)
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack input -> Eff (e : handlerEs) a -> Eff handlerEs (f a)
HasCallStack =>
input -> Eff (e : handlerEs) a -> Eff handlerEs (f a)
forall r.
HasCallStack =>
input -> Eff (e : handlerEs) r -> Eff handlerEs (f r)
handler input
input
    (Eff (e : handlerEs) a -> Eff handlerEs (f a))
-> ((Env (e : handlerEs) -> IO a) -> Eff (e : handlerEs) a)
-> (Env (e : handlerEs) -> IO a)
-> Eff handlerEs (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Env (e : handlerEs) -> IO a) -> Eff (e : handlerEs) a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env (e : handlerEs) -> IO a) -> IO (f a))
-> (Env (e : handlerEs) -> IO a) -> IO (f a)
forall a b. (a -> b) -> a -> b
$ \Env (e : handlerEs)
eProviderEs -> do
    Eff (e : es) a -> Env (e : es) -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff (e : es) a
action (Env (e : es) -> IO a) -> IO (Env (e : es)) -> IO a
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Env (e : handlerEs) -> Env es -> IO (Env (e : es))
forall (e :: Effect) (handlerEs :: [Effect]) (es :: [Effect]).
HasCallStack =>
Env (e : handlerEs) -> Env es -> IO (Env (e : es))
copyRef Env (e : handlerEs)
eProviderEs Env es
es

-- | Run the effect handler that doesn't change its return type with a given
-- input.
provideWith_
  :: (HasCallStack, Provider_ e input :> es)
  => input
  -- ^ The input to the effect handler.
  -> Eff (e : es) a
  -> Eff es a
provideWith_ :: forall (e :: Effect) input (es :: [Effect]) a.
(HasCallStack, Provider_ e input :> es) =>
input -> Eff (e : es) a -> Eff es a
provideWith_ input
input = Eff es (Identity a) -> Eff es a
forall (es :: [Effect]) a. Eff es (Identity a) -> Eff es a
adapt (Eff es (Identity a) -> Eff es a)
-> (Eff (e : es) a -> Eff es (Identity a))
-> Eff (e : es) a
-> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Eff (e : es) a -> Eff es (Identity a)
forall (e :: Effect) input (f :: Type -> Type) (es :: [Effect]) a.
(HasCallStack, Provider e input f :> es) =>
input -> Eff (e : es) a -> Eff es (f a)
provideWith input
input
  where
    adapt :: Eff es (Identity a) -> Eff es a
    adapt :: forall (es :: [Effect]) a. Eff es (Identity a) -> Eff es a
adapt = Eff es (Identity a) -> Eff es a
forall a b. Coercible a b => a -> b
coerce

----------------------------------------
-- Helpers

relinkProvider :: Relinker StaticRep (Provider e input f)
relinkProvider :: forall (e :: Effect) input (f :: Type -> Type).
Relinker StaticRep (Provider e input f)
relinkProvider = (HasCallStack =>
 (forall (es :: [Effect]). Env es -> IO (Env es))
 -> StaticRep (Provider e input f)
 -> IO (StaticRep (Provider e input f)))
-> Relinker StaticRep (Provider e input f)
forall (a :: Effect -> Type) (b :: Effect).
(HasCallStack =>
 (forall (es :: [Effect]). Env es -> IO (Env es))
 -> a b -> IO (a b))
-> Relinker a b
Relinker ((HasCallStack =>
  (forall (es :: [Effect]). Env es -> IO (Env es))
  -> StaticRep (Provider e input f)
  -> IO (StaticRep (Provider e input f)))
 -> Relinker StaticRep (Provider e input f))
-> (HasCallStack =>
    (forall (es :: [Effect]). Env es -> IO (Env es))
    -> StaticRep (Provider e input f)
    -> IO (StaticRep (Provider e input f)))
-> Relinker StaticRep (Provider e input f)
forall a b. (a -> b) -> a -> b
$ \forall (es :: [Effect]). Env es -> IO (Env es)
relink (Provider Env handlerEs
handlerEs forall r.
HasCallStack =>
input -> Eff (e : handlerEs) r -> Eff handlerEs (f r)
run) -> do
  Env handlerEs
newHandlerEs <- Env handlerEs -> IO (Env handlerEs)
forall (es :: [Effect]). Env es -> IO (Env es)
relink Env handlerEs
handlerEs
  StaticRep (Provider e input f)
-> IO (StaticRep (Provider e input f))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (StaticRep (Provider e input f)
 -> IO (StaticRep (Provider e input f)))
-> StaticRep (Provider e input f)
-> IO (StaticRep (Provider e input f))
forall a b. (a -> b) -> a -> b
$ Env handlerEs
-> (forall r.
    HasCallStack =>
    input -> Eff (e : handlerEs) r -> Eff handlerEs (f r))
-> StaticRep (Provider e input f)
forall (handlerEs :: [Effect]) input (e :: Effect)
       (f :: Type -> Type).
Env handlerEs
-> (forall r.
    HasCallStack =>
    input -> Eff (e : handlerEs) r -> Eff handlerEs (f r))
-> StaticRep (Provider e input f)
Provider Env handlerEs
newHandlerEs input -> Eff (e : handlerEs) r -> Eff handlerEs (f r)
forall r.
HasCallStack =>
input -> Eff (e : handlerEs) r -> Eff handlerEs (f r)
run

copyRef
  :: HasCallStack
  => Env (e : handlerEs)
  -> Env es
  -> IO (Env (e : es))
copyRef :: forall (e :: Effect) (handlerEs :: [Effect]) (es :: [Effect]).
HasCallStack =>
Env (e : handlerEs) -> Env es -> IO (Env (e : es))
copyRef (Env Int
hoffset PrimArray Ref
hrefs IORef' Storage
hstorage) (Env Int
offset PrimArray Ref
refs0 IORef' Storage
storage) = do
  Bool -> IO () -> IO ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (IORef' Storage
hstorage IORef' Storage -> IORef' Storage -> Bool
forall a. Eq a => a -> a -> Bool
/= IORef' Storage
storage) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"storages do not match"
  let size :: Int
size = PrimArray Ref -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Ref
refs0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset
  MutablePrimArray RealWorld Ref
mrefs <- Int -> IO (MutablePrimArray (PrimState IO) Ref)
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
Int -> m (MutablePrimArray (PrimState m) a)
newPrimArray (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  MutablePrimArray (PrimState IO) Ref -> Int -> Ref -> IO ()
forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutablePrimArray (PrimState m) a -> Int -> a -> m ()
writePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs Int
0 (Ref -> IO ()) -> Ref -> IO ()
forall a b. (a -> b) -> a -> b
$ PrimArray Ref -> Int -> Ref
forall a. Prim a => PrimArray a -> Int -> a
indexPrimArray PrimArray Ref
hrefs Int
hoffset
  MutablePrimArray (PrimState IO) Ref
-> Int -> PrimArray Ref -> Int -> Int -> IO ()
forall (m :: Type -> Type) a.
(PrimMonad m, Prim a) =>
MutablePrimArray (PrimState m) a
-> Int -> PrimArray a -> Int -> Int -> m ()
copyPrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs Int
1 PrimArray Ref
refs0 Int
offset Int
size
  PrimArray Ref
refs <- MutablePrimArray (PrimState IO) Ref -> IO (PrimArray Ref)
forall (m :: Type -> Type) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld Ref
MutablePrimArray (PrimState IO) Ref
mrefs
  Env (e : es) -> IO (Env (e : es))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Env (e : es) -> IO (Env (e : es)))
-> Env (e : es) -> IO (Env (e : es))
forall a b. (a -> b) -> a -> b
$ Int -> PrimArray Ref -> IORef' Storage -> Env (e : es)
forall (es :: [Effect]).
Int -> PrimArray Ref -> IORef' Storage -> Env es
Env Int
0 PrimArray Ref
refs IORef' Storage
storage