{-# LANGUAGE AllowAmbiguousTypes #-}
-- | Turn a handler of multiple effects into an effectful operation.
--
-- Generalizes "Effectful.Provider".
--
-- @since 2.3.1.0
module Effectful.Provider.List
  ( -- * Effect
    ProviderList
  , ProviderList_

    -- ** Handlers
  , runProviderList
  , runProviderList_

    -- ** Operations
  , provideList
  , provideList_
  , provideListWith
  , provideListWith_

    -- * Misc
  , type (++)
  , KnownEffects
  ) where

import Control.Monad
import Data.Coerce
import Data.Functor.Identity
import Data.Primitive.PrimArray

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

-- | Provide a way to run a handler of multiple @effects@ with a given @input@.
--
-- /Note:/ @f@ can be used to alter the return type of the handler. If that's
-- unnecessary, use 'ProviderList_'.
data ProviderList (effects :: [Effect]) (input :: Type) (f :: Type -> Type) :: Effect

-- | A restricted variant of 'ProviderList' with unchanged return type of the
-- handler.
type ProviderList_ effs input = ProviderList effs input Identity

type instance DispatchOf (ProviderList effs input f) = Static NoSideEffects

data instance StaticRep (ProviderList effs input f) where
  ProviderList
    :: KnownEffects effs
    => !(Env handlerEs)
    -> !(forall r. input -> Eff (effs ++ handlerEs) r -> Eff handlerEs (f r))
    -> StaticRep (ProviderList effs input f)

-- | Run the 'ProviderList' effect with a given handler.
runProviderList
  :: KnownEffects effs
  => (forall r. input -> Eff (effs ++ es) r -> Eff es (f r))
  -- ^ The handler.
  -> Eff (ProviderList effs input f : es) a
  -> Eff es a
runProviderList :: forall (effs :: [Effect]) input (es :: [Effect])
       (f :: Type -> Type) a.
KnownEffects effs =>
(forall r. input -> Eff (effs ++ es) r -> Eff es (f r))
-> Eff (ProviderList effs input f : es) a -> Eff es a
runProviderList forall r. input -> Eff (effs ++ es) r -> Eff es (f r)
run Eff (ProviderList effs 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 (ProviderList effs input f : es))
-> (Env (ProviderList effs input f : es) -> IO ())
-> (Env (ProviderList effs input f : es) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
inlineBracket
    (EffectRep
  (DispatchOf (ProviderList effs input f))
  (ProviderList effs input f)
-> Relinker
     (EffectRep (DispatchOf (ProviderList effs input f)))
     (ProviderList effs input f)
-> Env es
-> IO (Env (ProviderList effs input f : es))
forall (e :: Effect) (es :: [Effect]).
EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e
-> Env es
-> IO (Env (e : es))
consEnv (Env es
-> (forall r. input -> Eff (effs ++ es) r -> Eff es (f r))
-> StaticRep (ProviderList effs input f)
forall (effs :: [Effect]) (handlerEs :: [Effect]) input
       (f :: Type -> Type).
KnownEffects effs =>
Env handlerEs
-> (forall r.
    input -> Eff (effs ++ handlerEs) r -> Eff handlerEs (f r))
-> StaticRep (ProviderList effs input f)
ProviderList Env es
es0 input -> Eff (effs ++ es) r -> Eff es (f r)
forall r. input -> Eff (effs ++ es) r -> Eff es (f r)
run) Relinker
  (EffectRep (DispatchOf (ProviderList effs input f)))
  (ProviderList effs input f)
Relinker StaticRep (ProviderList effs input f)
forall (e :: [Effect]) input (f :: Type -> Type).
Relinker StaticRep (ProviderList e input f)
relinkProviderList Env es
es0)
    Env (ProviderList effs input f : es) -> IO ()
forall (e :: Effect) (es :: [Effect]). Env (e : es) -> IO ()
unconsEnv
    (\Env (ProviderList effs input f : es)
es -> Eff (ProviderList effs input f : es) a
-> Env (ProviderList effs input f : es) -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff (ProviderList effs input f : es) a
m Env (ProviderList effs input f : es)
es)

-- | Run the 'Provider' effect with a given handler that doesn't change its
-- return type.
runProviderList_
  :: KnownEffects effs
  => (forall r. input -> Eff (effs ++ es) r -> Eff es r)
  -- ^ The handler.
  -> Eff (ProviderList_ effs input : es) a
  -> Eff es a
runProviderList_ :: forall (effs :: [Effect]) input (es :: [Effect]) a.
KnownEffects effs =>
(forall r. input -> Eff (effs ++ es) r -> Eff es r)
-> Eff (ProviderList_ effs input : es) a -> Eff es a
runProviderList_ forall r. input -> Eff (effs ++ es) r -> Eff es r
run = (forall r. input -> Eff (effs ++ es) r -> Eff es (Identity r))
-> Eff (ProviderList effs input Identity : es) a -> Eff es a
forall (effs :: [Effect]) input (es :: [Effect])
       (f :: Type -> Type) a.
KnownEffects effs =>
(forall r. input -> Eff (effs ++ es) r -> Eff es (f r))
-> Eff (ProviderList effs input f : es) a -> Eff es a
runProviderList ((forall r. input -> Eff (effs ++ es) r -> Eff es (Identity r))
 -> Eff (ProviderList effs input Identity : es) a -> Eff es a)
-> (forall r. input -> Eff (effs ++ es) r -> Eff es (Identity r))
-> Eff (ProviderList effs 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 (effs ++ es) r -> Eff es r)
-> Eff (effs ++ es) r
-> Eff es (Identity r)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Eff (effs ++ es) r -> Eff es r
forall r. input -> Eff (effs ++ es) r -> Eff es r
run input
input

-- | Run the handler.
provideList
  :: forall effs f es a
   . ProviderList effs () f :> es
  => Eff (effs ++ es) a
  -> Eff es (f a)
provideList :: forall (effs :: [Effect]) (f :: Type -> Type) (es :: [Effect]) a.
(ProviderList effs () f :> es) =>
Eff (effs ++ es) a -> Eff es (f a)
provideList = forall (effs :: [Effect]) input (f :: Type -> Type)
       (es :: [Effect]) a.
(ProviderList effs input f :> es) =>
input -> Eff (effs ++ es) a -> Eff es (f a)
provideListWith @effs ()

-- | Run the handler with unchanged return type.
provideList_
  :: forall effs es a
   . ProviderList_ effs () :> es
  => Eff (effs ++ es) a
  -> Eff es a
provideList_ :: forall (effs :: [Effect]) (es :: [Effect]) a.
(ProviderList_ effs () :> es) =>
Eff (effs ++ es) a -> Eff es a
provideList_ = forall (effs :: [Effect]) input (es :: [Effect]) a.
(ProviderList_ effs input :> es) =>
input -> Eff (effs ++ es) a -> Eff es a
provideListWith_ @effs ()

-- | Run the handler with a given input.
provideListWith
  :: forall effs input f es a
   . ProviderList effs input f :> es
  => input
  -- ^ The input to the handler.
  -> Eff (effs ++ es) a
  -> Eff es (f a)
provideListWith :: forall (effs :: [Effect]) input (f :: Type -> Type)
       (es :: [Effect]) a.
(ProviderList effs input f :> es) =>
input -> Eff (effs ++ es) a -> Eff es (f a)
provideListWith input
input Eff (effs ++ 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
  ProviderList (Env handlerEs
handlerEs :: Env handlerEs) forall r. input -> Eff (effs ++ handlerEs) r -> Eff handlerEs (f r)
run <- forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
Env es -> IO (EffectRep (DispatchOf e) e)
getEnv @(ProviderList effs input f) 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) (Eff handlerEs (f a) -> IO (f a))
-> ((Env (effs ++ handlerEs) -> IO a) -> Eff handlerEs (f a))
-> (Env (effs ++ handlerEs) -> IO a)
-> IO (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. input -> Eff (effs ++ handlerEs) a -> Eff handlerEs (f a)
forall r. input -> Eff (effs ++ handlerEs) r -> Eff handlerEs (f r)
run input
input (Eff (effs ++ handlerEs) a -> Eff handlerEs (f a))
-> ((Env (effs ++ handlerEs) -> IO a) -> Eff (effs ++ handlerEs) a)
-> (Env (effs ++ handlerEs) -> IO a)
-> Eff handlerEs (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Env (effs ++ handlerEs) -> IO a) -> Eff (effs ++ handlerEs) a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env (effs ++ handlerEs) -> IO a) -> IO (f a))
-> (Env (effs ++ handlerEs) -> IO a) -> IO (f a)
forall a b. (a -> b) -> a -> b
$ \Env (effs ++ handlerEs)
eHandlerEs -> do
    Eff (effs ++ es) a -> Env (effs ++ es) -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff (effs ++ es) a
action (Env (effs ++ es) -> IO a) -> IO (Env (effs ++ es)) -> IO a
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (effs :: [Effect]) (handlerEs :: [Effect]) (es :: [Effect]).
KnownEffects effs =>
Env (effs ++ handlerEs) -> Env es -> IO (Env (effs ++ es))
copyRefs @effs @handlerEs Env (effs ++ handlerEs)
eHandlerEs Env es
es

-- | Run the handler that doesn't change its return type with a given input.
provideListWith_
  :: forall effs input es a
   . ProviderList_ effs input :> es
  => input
  -- ^ The input to the handler.
  -> Eff (effs ++ es) a
  -> Eff es a
provideListWith_ :: forall (effs :: [Effect]) input (es :: [Effect]) a.
(ProviderList_ effs input :> es) =>
input -> Eff (effs ++ es) a -> Eff es a
provideListWith_ input
input = Eff es (Identity a) -> Eff es a
adapt (Eff es (Identity a) -> Eff es a)
-> (Eff (effs ++ es) a -> Eff es (Identity a))
-> Eff (effs ++ es) a
-> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (effs :: [Effect]) input (f :: Type -> Type)
       (es :: [Effect]) a.
(ProviderList effs input f :> es) =>
input -> Eff (effs ++ es) a -> Eff es (f a)
provideListWith @effs input
input
  where
    adapt :: Eff es (Identity a) -> Eff es a
    adapt :: 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

relinkProviderList :: Relinker StaticRep (ProviderList e input f)
relinkProviderList :: forall (e :: [Effect]) input (f :: Type -> Type).
Relinker StaticRep (ProviderList e input f)
relinkProviderList = ((forall (es :: [Effect]). Env es -> IO (Env es))
 -> StaticRep (ProviderList e input f)
 -> IO (StaticRep (ProviderList e input f)))
-> Relinker StaticRep (ProviderList e input f)
forall (a :: Effect -> Type) (b :: Effect).
((forall (es :: [Effect]). Env es -> IO (Env es))
 -> a b -> IO (a b))
-> Relinker a b
Relinker (((forall (es :: [Effect]). Env es -> IO (Env es))
  -> StaticRep (ProviderList e input f)
  -> IO (StaticRep (ProviderList e input f)))
 -> Relinker StaticRep (ProviderList e input f))
-> ((forall (es :: [Effect]). Env es -> IO (Env es))
    -> StaticRep (ProviderList e input f)
    -> IO (StaticRep (ProviderList e input f)))
-> Relinker StaticRep (ProviderList e input f)
forall a b. (a -> b) -> a -> b
$ \forall (es :: [Effect]). Env es -> IO (Env es)
relink (ProviderList Env handlerEs
handlerEs forall r. 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 (ProviderList e input f)
-> IO (StaticRep (ProviderList e input f))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (StaticRep (ProviderList e input f)
 -> IO (StaticRep (ProviderList e input f)))
-> StaticRep (ProviderList e input f)
-> IO (StaticRep (ProviderList e input f))
forall a b. (a -> b) -> a -> b
$ Env handlerEs
-> (forall r.
    input -> Eff (e ++ handlerEs) r -> Eff handlerEs (f r))
-> StaticRep (ProviderList e input f)
forall (effs :: [Effect]) (handlerEs :: [Effect]) input
       (f :: Type -> Type).
KnownEffects effs =>
Env handlerEs
-> (forall r.
    input -> Eff (effs ++ handlerEs) r -> Eff handlerEs (f r))
-> StaticRep (ProviderList effs input f)
ProviderList Env handlerEs
newHandlerEs input -> Eff (e ++ handlerEs) r -> Eff handlerEs (f r)
forall r. input -> Eff (e ++ handlerEs) r -> Eff handlerEs (f r)
run

copyRefs
  :: forall effs handlerEs es
   . KnownEffects effs
  => Env (effs ++ handlerEs)
  -> Env es
  -> IO (Env (effs ++ es))
copyRefs :: forall (effs :: [Effect]) (handlerEs :: [Effect]) (es :: [Effect]).
KnownEffects effs =>
Env (effs ++ handlerEs) -> Env es -> IO (Env (effs ++ es))
copyRefs (Env Int
hoffset PrimArray Int
hrefs IORef' Storage
hstorage) (Env Int
offset PrimArray Int
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 Int -> Int
forall a. Prim a => PrimArray a -> Int
sizeofPrimArray PrimArray Int
refs0 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset
      effsSize :: Int
effsSize = Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* forall (es :: [Effect]). KnownEffects es => Int
knownEffectsLength @effs
  MutablePrimArray RealWorld Int
mrefs <- Int -> IO (MutablePrimArray (PrimState IO) Int)
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
effsSize)
  MutablePrimArray (PrimState IO) Int
-> Int -> PrimArray Int -> 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 Int
MutablePrimArray (PrimState IO) Int
mrefs Int
0 PrimArray Int
hrefs Int
hoffset Int
effsSize
  MutablePrimArray (PrimState IO) Int
-> Int -> PrimArray Int -> 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 Int
MutablePrimArray (PrimState IO) Int
mrefs Int
effsSize PrimArray Int
refs0 Int
offset Int
size
  PrimArray Int
refs <- MutablePrimArray (PrimState IO) Int -> IO (PrimArray Int)
forall (m :: Type -> Type) a.
PrimMonad m =>
MutablePrimArray (PrimState m) a -> m (PrimArray a)
unsafeFreezePrimArray MutablePrimArray RealWorld Int
MutablePrimArray (PrimState IO) Int
mrefs
  Env (effs ++ es) -> IO (Env (effs ++ es))
forall a. a -> IO a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Env (effs ++ es) -> IO (Env (effs ++ es)))
-> Env (effs ++ es) -> IO (Env (effs ++ es))
forall a b. (a -> b) -> a -> b
$ Int -> PrimArray Int -> IORef' Storage -> Env (effs ++ es)
forall (es :: [Effect]).
Int -> PrimArray Int -> IORef' Storage -> Env es
Env Int
0 PrimArray Int
refs IORef' Storage
storage