-- | Dynamically dispatched effects.
module Effectful.Dispatch.Dynamic
  ( -- * Introduction
    -- $intro

    -- ** An example
    -- $example

    -- ** First order and higher order effects
    -- $order

    -- * Sending operations to the handler
    send

    -- * Handling effects
  , EffectHandler
  , interpret
  , reinterpret
  , interpose
  , impose

    -- ** Handling local 'Eff' computations
  , LocalEnv

    -- *** Unlifts
  , localSeqUnlift
  , localSeqUnliftIO
  , localUnlift
  , localUnliftIO

    -- *** Lifts
  , withLiftMap
  , withLiftMapIO

    -- *** Bidirectional lifts
  , localLiftUnlift
  , localLiftUnliftIO

    -- *** Utils
  , SuffixOf

    -- * Re-exports
  , HasCallStack
  ) where

import Control.Exception (bracket)
import Control.Monad.IO.Unlift
import Data.Kind
import GHC.Stack (HasCallStack)

import Effectful.Internal.Effect
import Effectful.Internal.Env
import Effectful.Internal.Monad

-- $intro
--
-- A dynamically dispatched effect is a collection of operations that can be
-- interpreted in different ways at runtime, depending on the handler that is
-- used to run the effect.
--
-- This allows a programmer to separate the __what__ from the __how__,
-- i.e. define effects that model what the code should do, while providing
-- handlers that determine how it should do it later. Moreover, different
-- environments can use different handlers to change the behavior of specific
-- parts of the application if appropriate.
--

-- $example
--
-- Let's create an effect for basic file access, i.e. writing and reading files.
--
-- First, we need to define a generalized algebraic data type of kind 'Effect',
-- where each constructor corresponds to a specific operation of the effect in
-- question.
--
-- >>> :{
--   data FileSystem :: Effect where
--     ReadFile  :: FilePath -> FileSystem m String
--     WriteFile :: FilePath -> String -> FileSystem m ()
-- :}
--
-- >>> type instance DispatchOf FileSystem = Dynamic
--
-- The @FileSystem@ effect has two operations:
--
-- - @ReadFile@, which takes a @FilePath@ and returns a @String@ in the monadic
--   context.
--
-- - @WriteFile@, which takes a @FilePath@, a @String@ and returns a @()@ in the
--   monadic context.
--
-- For people familiar with the @mtl@ style effects, note that the syntax looks
-- very similar to defining an appropriate type class:
--
-- @
-- class FileSystem m where
--   readFile  :: FilePath -> m String
--   writeFile :: FilePath -> String -> m ()
-- @
--
-- The biggest difference between these two is that the definition of a type
-- class gives us operations as functions, while the definition of an effect
-- gives us operations as data constructors. They can be turned into functions
-- with the help of 'send':
--
-- >>> :{
--   readFile :: (HasCallStack, FileSystem :> es) => FilePath -> Eff es String
--   readFile path = send (ReadFile path)
-- :}
--
-- >>> :{
--   writeFile :: (HasCallStack, FileSystem :> es) => FilePath -> String -> Eff es ()
--   writeFile path content = send (WriteFile path content)
-- :}
--
-- /Note:/ the above functions and the 'DispatchOf' instance can also be
-- automatically generated by the @makeEffect@ function from the @effectful-th@
-- library.
--
-- The following defines an 'EffectHandler' that reads and writes files from the
-- drive:
--
-- >>> import Control.Exception (IOException)
-- >>> import Control.Monad.Catch (catch)
-- >>> import qualified System.IO as IO
--
-- >>> import Effectful.Error.Static
--
-- >>> newtype FsError = FsError String deriving Show
--
-- >>> :{
--  runFileSystemIO
--    :: (IOE :> es, Error FsError :> es)
--    => Eff (FileSystem : es) a
--    -> Eff es a
--  runFileSystemIO = interpret $ \_ -> \case
--    ReadFile path           -> adapt $ IO.readFile path
--    WriteFile path contents -> adapt $ IO.writeFile path contents
--    where
--      adapt m = liftIO m `catch` \(e::IOException) -> throwError . FsError $ show e
-- :}
--
-- Here, we use 'interpret' and simply execute corresponding 'IO' actions for
-- each operation, additionally doing a bit of error management.
--
-- On the other hand, maybe there is a situation in which instead of interacting
-- with the outside world, a pure, in-memory storage is preferred:
--
-- >>> import qualified Data.Map.Strict as M
--
-- >>> import Effectful.State.Static.Local
--
-- >>> :{
--   runFileSystemPure
--     :: Error FsError :> es
--     => M.Map FilePath String
--     -> Eff (FileSystem : es) a
--     -> Eff es a
--   runFileSystemPure fs0 = reinterpret (evalState fs0) $ \_ -> \case
--     ReadFile path -> gets (M.lookup path) >>= \case
--       Just contents -> pure contents
--       Nothing       -> throwError . FsError $ "File not found: " ++ show path
--     WriteFile path contents -> modify $ M.insert path contents
-- :}
--
-- Here, we use 'reinterpret' and introduce a
-- 'Effectful.State.Static.Local.State' effect for the storage that is private
-- to the effect handler and cannot be accessed outside of it.
--
-- Let's compare how these differ.
--
-- >>> :{
--   action = do
--     file <- readFile "effectful-core.cabal"
--     pure $ length file > 0
-- :}
--
-- >>> :t action
-- action :: (FileSystem :> es) => Eff es Bool
--
-- >>> runEff . runError @FsError . runFileSystemIO $ action
-- Right True
--
-- >>> runPureEff . runErrorNoCallStack @FsError . runFileSystemPure M.empty $ action
-- Left (FsError "File not found: \"effectful-core.cabal\"")
--

-- $order
--
-- Note that the definition of the @FileSystem@ effect from the previous section
-- doesn't use the @m@ type parameter. What is more, when the effect is
-- interpreted, the 'LocalEnv' argument of the 'EffectHandler' is also not
-- used. Such effects are /first order/.
--
-- If an effect makes use of the @m@ parameter, it is a /higher order effect/.
--
-- Interpretation of higher order effects is slightly more involved. To see why,
-- let's consider the @Profiling@ effect for logging how much time a specific
-- action took to run:
--
-- >>> :{
--   data Profiling :: Effect where
--     Profile :: String -> m a -> Profiling m a
-- :}
--
-- >>> type instance DispatchOf Profiling = Dynamic
--
-- >>> :{
--   profile :: (HasCallStack, Profiling :> es) => String -> Eff es a -> Eff es a
--   profile label action = send (Profile label action)
-- :}
--
-- If we naively try to interpret it, we will run into trouble:
--
-- >>> import GHC.Clock (getMonotonicTime)
--
-- >>> :{
--  runProfiling :: IOE :> es => Eff (Profiling : es) a -> Eff es a
--  runProfiling = interpret $ \_ -> \case
--    Profile label action -> do
--      t1 <- liftIO getMonotonicTime
--      r <- action
--      t2 <- liftIO getMonotonicTime
--      liftIO . putStrLn $ "Action '" ++ label ++ "' took " ++ show (t2 - t1) ++ " seconds."
--      pure r
-- :}
-- ...
-- ... Couldn't match type ‘localEs’ with ‘es’
-- ...
--
-- The problem is that @action@ has a type @Eff localEs a@, while the monad of
-- the effect handler is @Eff es@. @localEs@ represents the /local environment/
-- in which the @Profile@ operation was called, which is opaque as the effect
-- handler cannot possibly know how it looks like.
--
-- The solution is to use the 'LocalEnv' that an 'EffectHandler' is given to run
-- the action using one of the functions from the 'localUnlift' family:
--
-- >>> :{
--  runProfiling :: IOE :> es => Eff (Profiling : es) a -> Eff es a
--  runProfiling = interpret $ \env -> \case
--    Profile label action -> localSeqUnliftIO env $ \unlift -> do
--      t1 <- getMonotonicTime
--      r <- unlift action
--      t2 <- getMonotonicTime
--      putStrLn $ "Action '" ++ label ++ "' took " ++ show (t2 - t1) ++ " seconds."
--      pure r
-- :}
--
-- In a similar way we can define a dummy interpreter that does no profiling:
--
-- >>> :{
--  runNoProfiling :: Eff (Profiling : es) a -> Eff es a
--  runNoProfiling = interpret $ \env -> \case
--    Profile label action -> localSeqUnlift env $ \unlift -> unlift action
-- :}
--
-- ...and it's done.
--
-- >>> action = profile "greet" . liftIO $ putStrLn "Hello!"
--
-- >>> :t action
-- action :: (Profiling :> es, IOE :> es) => Eff es ()
--
-- >>> runEff . runProfiling $ action
-- Hello!
-- Action 'greet' took ... seconds.
--
-- >>> runEff . runNoProfiling $ action
-- Hello!
--

----------------------------------------
-- Handling effects

-- | Interpret an effect.
interpret
  :: DispatchOf e ~ Dynamic
  => EffectHandler e es
  -- ^ The effect handler.
  -> Eff (e : es) a
  -> Eff      es  a
interpret :: forall (e :: Effect) (es :: [Effect]) a.
(DispatchOf e ~ 'Dynamic) =>
EffectHandler e es -> Eff (e : es) a -> Eff es a
interpret EffectHandler e es
handler Eff (e : 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
es -> do
  Env es
les <- Env es -> IO (Env es)
forall (es :: [Effect]). Env es -> IO (Env es)
forkEnv Env es
es
  (Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es) (Eff es a -> IO a) -> Eff es a -> IO a
forall a b. (a -> b) -> a -> b
$ Handler e -> Eff (e : es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(DispatchOf e ~ 'Dynamic) =>
Handler e -> Eff (e : es) a -> Eff es a
runHandler (Env es -> EffectHandler e es -> Handler e
forall (es :: [Effect]) (e :: Effect).
Env es -> EffectHandler e es -> Handler e
Handler Env es
les EffectHandler e es
handler) Eff (e : es) a
m

-- | Interpret an effect using other, private effects.
--
-- @'interpret' ≡ 'reinterpret' 'id'@
reinterpret
  :: DispatchOf e ~ Dynamic
  => (Eff handlerEs a -> Eff es b)
  -- ^ Introduction of effects encapsulated within the handler.
  -> EffectHandler e handlerEs
  -- ^ The effect handler.
  -> Eff (e : es) a
  -> Eff      es  b
reinterpret :: forall (e :: Effect) (handlerEs :: [Effect]) a (es :: [Effect]) b.
(DispatchOf e ~ 'Dynamic) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff (e : es) a -> Eff es b
reinterpret Eff handlerEs a -> Eff es b
runHandlerEs EffectHandler e handlerEs
handler Eff (e : es) a
m = (Env es -> IO b) -> Eff es b
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO b) -> Eff es b) -> (Env es -> IO b) -> Eff es b
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  Env es
les0 <- Env es -> IO (Env es)
forall (es :: [Effect]). Env es -> IO (Env es)
forkEnv Env es
es
  (Eff es b -> Env es -> IO b
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
les0) (Eff es b -> IO b)
-> ((Env handlerEs -> IO a) -> Eff es b)
-> (Env handlerEs -> IO a)
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff handlerEs a -> Eff es b
runHandlerEs (Eff handlerEs a -> Eff es b)
-> ((Env handlerEs -> IO a) -> Eff handlerEs a)
-> (Env handlerEs -> IO a)
-> Eff es b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Env handlerEs -> IO a) -> Eff handlerEs a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env handlerEs -> IO a) -> IO b)
-> (Env handlerEs -> IO a) -> IO b
forall a b. (a -> b) -> a -> b
$ \Env handlerEs
les -> do
    (Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es) (Eff es a -> IO a) -> Eff es a -> IO a
forall a b. (a -> b) -> a -> b
$ Handler e -> Eff (e : es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(DispatchOf e ~ 'Dynamic) =>
Handler e -> Eff (e : es) a -> Eff es a
runHandler (Env handlerEs -> EffectHandler e handlerEs -> Handler e
forall (es :: [Effect]) (e :: Effect).
Env es -> EffectHandler e es -> Handler e
Handler Env handlerEs
les EffectHandler e handlerEs
handler) Eff (e : es) a
m

-- | Replace the handler of an existing effect with a new one.
--
-- /Note:/ this function allows for augmenting handlers with a new functionality
-- as the new handler can send operations to the old one.
--
-- >>> :{
--   data E :: Effect where
--     Op :: E m ()
--   type instance DispatchOf E = Dynamic
-- :}
--
-- >>> :{
--   runE :: IOE :> es => Eff (E : es) a -> Eff es a
--   runE = interpret $ \_ Op -> liftIO (putStrLn "op")
-- :}
--
-- >>> runEff . runE $ send Op
-- op
--
-- >>> :{
--   augmentE :: (E :> es, IOE :> es) => Eff es a -> Eff es a
--   augmentE = interpose $ \_ Op -> liftIO (putStrLn "augmented op") >> send Op
-- :}
--
-- >>> runEff . runE . augmentE $ send Op
-- augmented op
-- op
--
interpose
  :: forall e es a. (DispatchOf e ~ Dynamic, e :> es)
  => EffectHandler e es
  -- ^ The effect handler.
  -> Eff es a
  -> Eff es a
interpose :: forall (e :: Effect) (es :: [Effect]) a.
(DispatchOf e ~ 'Dynamic, e :> es) =>
EffectHandler e es -> Eff es a -> Eff es a
interpose EffectHandler e es
handler Eff 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
  Env es
les <- Env es -> IO (Env es)
forall (es :: [Effect]). Env es -> IO (Env es)
forkEnv Env es
es0
  IO (Env es) -> (Env es -> IO ()) -> (Env es -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env es)
forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env es)
replaceEnv (Env es -> EffectHandler e es -> Handler e
forall (es :: [Effect]) (e :: Effect).
Env es -> EffectHandler e es -> Handler e
Handler Env es
les EffectHandler e es
handler) Relinker (EffectRep (DispatchOf e)) e
forall (e :: Effect). Relinker Handler e
relinkHandler Env es
es0)
          (forall (e :: Effect) (es :: [Effect]). (e :> es) => Env es -> IO ()
unreplaceEnv @e)
          (\Env es
es -> Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff es a
m Env es
es)

-- | Replace the handler of an existing effect with a new one that uses other,
-- private effects.
--
-- @'interpose' ≡ 'impose' 'id'@
impose
  :: forall e es handlerEs a b. (DispatchOf e ~ Dynamic, e :> es)
  => (Eff handlerEs a -> Eff es b)
  -- ^ Introduction of effects encapsulated within the handler.
  -> EffectHandler e handlerEs
  -- ^ The effect handler.
  -> Eff es a
  -> Eff es b
impose :: forall (e :: Effect) (es :: [Effect]) (handlerEs :: [Effect]) a b.
(DispatchOf e ~ 'Dynamic, e :> es) =>
(Eff handlerEs a -> Eff es b)
-> EffectHandler e handlerEs -> Eff es a -> Eff es b
impose Eff handlerEs a -> Eff es b
runHandlerEs EffectHandler e handlerEs
handler Eff es a
m = (Env es -> IO b) -> Eff es b
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO b) -> Eff es b) -> (Env es -> IO b) -> Eff es b
forall a b. (a -> b) -> a -> b
$ \Env es
es0 -> do
  Env es
les0 <- Env es -> IO (Env es)
forall (es :: [Effect]). Env es -> IO (Env es)
forkEnv Env es
es0
  (Eff es b -> Env es -> IO b
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
les0) (Eff es b -> IO b)
-> ((Env handlerEs -> IO a) -> Eff es b)
-> (Env handlerEs -> IO a)
-> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff handlerEs a -> Eff es b
runHandlerEs (Eff handlerEs a -> Eff es b)
-> ((Env handlerEs -> IO a) -> Eff handlerEs a)
-> (Env handlerEs -> IO a)
-> Eff es b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Env handlerEs -> IO a) -> Eff handlerEs a
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env handlerEs -> IO a) -> IO b)
-> (Env handlerEs -> IO a) -> IO b
forall a b. (a -> b) -> a -> b
$ \Env handlerEs
les -> do
    IO (Env es) -> (Env es -> IO ()) -> (Env es -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env es)
forall (e :: Effect) (es :: [Effect]).
(e :> es) =>
EffectRep (DispatchOf e) e
-> Relinker (EffectRep (DispatchOf e)) e -> Env es -> IO (Env es)
replaceEnv (Env handlerEs -> EffectHandler e handlerEs -> Handler e
forall (es :: [Effect]) (e :: Effect).
Env es -> EffectHandler e es -> Handler e
Handler Env handlerEs
les EffectHandler e handlerEs
handler) Relinker (EffectRep (DispatchOf e)) e
forall (e :: Effect). Relinker Handler e
relinkHandler Env es
es0)
            (forall (e :: Effect) (es :: [Effect]). (e :> es) => Env es -> IO ()
unreplaceEnv @e)
            (\Env es
es -> Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
unEff Eff es a
m Env es
es)

----------------------------------------
-- Unlifts

-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
-- general version see 'localUnlift'.
localSeqUnlift
  :: (HasCallStack, SuffixOf es handlerEs)
  => LocalEnv localEs handlerEs
  -- ^ Local environment.
  -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
  -- ^ Continuation with the unlifting function in scope.
  -> Eff es a
localSeqUnlift :: forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) a.
(HasCallStack, SuffixOf es handlerEs) =>
LocalEnv localEs handlerEs
-> ((forall r. Eff localEs r -> Eff es r) -> Eff es a) -> Eff es a
localSeqUnlift (LocalEnv Env localEs
les) (forall r. Eff localEs r -> Eff es r) -> Eff es a
k = (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
es -> do
  Env localEs -> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
seqUnliftIO Env localEs
les (((forall r. Eff localEs r -> IO r) -> IO a) -> IO a)
-> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall r. Eff localEs r -> IO r
unlift -> do
    (Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es) (Eff es a -> IO a) -> Eff es a -> IO a
forall a b. (a -> b) -> a -> b
$ (forall r. Eff localEs r -> Eff es r) -> Eff es a
k ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
-> (forall r. Eff localEs r -> Eff es r) -> Eff es a
forall a b. (a -> b) -> a -> b
$ IO r -> Eff es r
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_ (IO r -> Eff es r)
-> (Eff localEs r -> IO r) -> Eff localEs r -> Eff es r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff localEs r -> IO r
forall r. Eff localEs r -> IO r
unlift

-- | Create a local unlifting function with the 'SeqUnlift' strategy. For the
-- general version see 'localUnliftIO'.
localSeqUnliftIO
  :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
  => LocalEnv localEs handlerEs
  -- ^ Local environment.
  -> ((forall r. Eff localEs r -> IO r) -> IO a)
  -- ^ Continuation with the unlifting function in scope.
  -> Eff es a
localSeqUnliftIO :: forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) a.
(HasCallStack, SuffixOf es handlerEs, IOE :> es) =>
LocalEnv localEs handlerEs
-> ((forall r. Eff localEs r -> IO r) -> IO a) -> Eff es a
localSeqUnliftIO (LocalEnv Env localEs
les) (forall r. Eff localEs r -> IO r) -> IO a
k = IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Env localEs -> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
seqUnliftIO Env localEs
les (forall r. Eff localEs r -> IO r) -> IO a
k

-- | Create a local unlifting function with the given strategy.
localUnlift
  :: (HasCallStack, SuffixOf es handlerEs)
  => LocalEnv localEs handlerEs
  -- ^ Local environment.
  -> UnliftStrategy
  -> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
  -- ^ Continuation with the unlifting function in scope.
  -> Eff es a
localUnlift :: forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) a.
(HasCallStack, SuffixOf es handlerEs) =>
LocalEnv localEs handlerEs
-> UnliftStrategy
-> ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
-> Eff es a
localUnlift (LocalEnv Env localEs
les) UnliftStrategy
strategy (forall r. Eff localEs r -> Eff es r) -> Eff es a
k = case UnliftStrategy
strategy of
  UnliftStrategy
SeqUnlift -> (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
es -> do
    Env localEs -> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
seqUnliftIO Env localEs
les (((forall r. Eff localEs r -> IO r) -> IO a) -> IO a)
-> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall r. Eff localEs r -> IO r
unlift -> do
      (Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es) (Eff es a -> IO a) -> Eff es a -> IO a
forall a b. (a -> b) -> a -> b
$ (forall r. Eff localEs r -> Eff es r) -> Eff es a
k ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
-> (forall r. Eff localEs r -> Eff es r) -> Eff es a
forall a b. (a -> b) -> a -> b
$ IO r -> Eff es r
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_ (IO r -> Eff es r)
-> (Eff localEs r -> IO r) -> Eff localEs r -> Eff es r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff localEs r -> IO r
forall r. Eff localEs r -> IO r
unlift
  ConcUnlift Persistence
p Limit
l -> (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
es -> do
    Env localEs
-> Persistence
-> Limit
-> ((forall r. Eff localEs r -> IO r) -> IO a)
-> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es
-> Persistence
-> Limit
-> ((forall r. Eff es r -> IO r) -> IO a)
-> IO a
concUnliftIO Env localEs
les Persistence
p Limit
l (((forall r. Eff localEs r -> IO r) -> IO a) -> IO a)
-> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall r. Eff localEs r -> IO r
unlift -> do
      (Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es) (Eff es a -> IO a) -> Eff es a -> IO a
forall a b. (a -> b) -> a -> b
$ (forall r. Eff localEs r -> Eff es r) -> Eff es a
k ((forall r. Eff localEs r -> Eff es r) -> Eff es a)
-> (forall r. Eff localEs r -> Eff es r) -> Eff es a
forall a b. (a -> b) -> a -> b
$ IO r -> Eff es r
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_ (IO r -> Eff es r)
-> (Eff localEs r -> IO r) -> Eff localEs r -> Eff es r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff localEs r -> IO r
forall r. Eff localEs r -> IO r
unlift

-- | Create a local unlifting function with the given strategy.
localUnliftIO
  :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
  => LocalEnv localEs handlerEs
  -- ^ Local environment.
  -> UnliftStrategy
  -> ((forall r. Eff localEs r -> IO r) -> IO a)
  -- ^ Continuation with the unlifting function in scope.
  -> Eff es a
localUnliftIO :: forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) a.
(HasCallStack, SuffixOf es handlerEs, IOE :> es) =>
LocalEnv localEs handlerEs
-> UnliftStrategy
-> ((forall r. Eff localEs r -> IO r) -> IO a)
-> Eff es a
localUnliftIO (LocalEnv Env localEs
les) UnliftStrategy
strategy (forall r. Eff localEs r -> IO r) -> IO a
k = case UnliftStrategy
strategy of
  UnliftStrategy
SeqUnlift      -> IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Env localEs -> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
seqUnliftIO Env localEs
les (forall r. Eff localEs r -> IO r) -> IO a
k
  ConcUnlift Persistence
p Limit
l -> IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Env localEs
-> Persistence
-> Limit
-> ((forall r. Eff localEs r -> IO r) -> IO a)
-> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es
-> Persistence
-> Limit
-> ((forall r. Eff es r -> IO r) -> IO a)
-> IO a
concUnliftIO Env localEs
les Persistence
p Limit
l (forall r. Eff localEs r -> IO r) -> IO a
k

-- | Utility for lifting 'Eff' computations of type
--
-- @'Eff' es a -> 'Eff' es b@
--
-- to
--
-- @'Eff' localEs a -> 'Eff' localEs b@
--
-- /Note:/ the computation must not run its argument in a different thread,
-- attempting to do so will result in a runtime error.
withLiftMap
  :: (HasCallStack, SuffixOf es handlerEs)
  => LocalEnv localEs handlerEs
  -- ^ Local environment.
  -> ((forall a b. (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
  -- ^ Continuation with the lifting function in scope.
  -> Eff es r
withLiftMap :: forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) r.
(HasCallStack, SuffixOf es handlerEs) =>
LocalEnv localEs handlerEs
-> ((forall a b.
     (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b)
    -> Eff es r)
-> Eff es r
withLiftMap !LocalEnv localEs handlerEs
_ (forall a b.
 (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b)
-> Eff es r
k = (Env es -> IO r) -> Eff es r
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env es -> IO r) -> Eff es r) -> (Env es -> IO r) -> Eff es r
forall a b. (a -> b) -> a -> b
$ \Env es
es -> do
  -- The LocalEnv parameter is not used, but we need it to constraint the
  -- localEs type variable. It's also strict so that callers don't cheat.
  (Eff es r -> Env es -> IO r
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es) (Eff es r -> IO r) -> Eff es r -> IO r
forall a b. (a -> b) -> a -> b
$ (forall a b.
 (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b)
-> Eff es r
k ((forall a b.
  (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b)
 -> Eff es r)
-> (forall a b.
    (Eff es a -> Eff es b) -> Eff localEs a -> Eff localEs b)
-> Eff es r
forall a b. (a -> b) -> a -> b
$ \Eff es a -> Eff es b
mapEff Eff localEs a
m -> (Env localEs -> IO b) -> Eff localEs b
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env localEs -> IO b) -> Eff localEs b)
-> (Env localEs -> IO b) -> Eff localEs b
forall a b. (a -> b) -> a -> b
$ \Env localEs
localEs -> do
    Env localEs -> ((forall r. Eff localEs r -> IO r) -> IO b) -> IO b
forall (es :: [Effect]) a.
HasCallStack =>
Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
seqUnliftIO Env localEs
localEs (((forall r. Eff localEs r -> IO r) -> IO b) -> IO b)
-> ((forall r. Eff localEs r -> IO r) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall r. Eff localEs r -> IO r
unlift -> do
      (Eff es b -> Env es -> IO b
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es) (Eff es b -> IO b) -> (IO a -> Eff es b) -> IO a -> IO b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff es a -> Eff es b
mapEff (Eff es a -> Eff es b) -> (IO a -> Eff es a) -> IO a -> Eff es b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> Eff es a
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_ (IO a -> IO b) -> IO a -> IO b
forall a b. (a -> b) -> a -> b
$ Eff localEs a -> IO a
forall r. Eff localEs r -> IO r
unlift Eff localEs a
m

-- | Utility for lifting 'IO' computations of type
--
-- @'IO' a -> 'IO' b@
--
-- to
--
-- @'Eff' localEs a -> 'Eff' localEs b@
--
-- /Note:/ the computation must not run its argument in a different thread,
-- attempting to do so will result in a runtime error.
--
-- Useful e.g. for lifting the unmasking function in
-- 'Control.Exception.mask'-like computations:
--
-- >>> :{
-- data Fork :: Effect where
--   ForkWithUnmask :: ((forall a. m a -> m a) -> m ()) -> Fork m ThreadId
-- type instance DispatchOf Fork = Dynamic
-- :}
--
-- >>> :{
-- runFork :: IOE :> es => Eff (Fork : es) a -> Eff es a
-- runFork = interpret $ \env (ForkWithUnmask m) -> withLiftMapIO env $ \liftMap -> do
--   localUnliftIO env (ConcUnlift Ephemeral $ Limited 1) $ \unlift -> do
--     forkIOWithUnmask $ \unmask -> unlift $ m $ liftMap unmask
-- :}
withLiftMapIO
  :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
  => LocalEnv localEs handlerEs
  -- ^ Local environment.
  -> ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b) -> Eff es r)
  -- ^ Continuation with the lifting function in scope.
  -> Eff es r
withLiftMapIO :: forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) r.
(HasCallStack, SuffixOf es handlerEs, IOE :> es) =>
LocalEnv localEs handlerEs
-> ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b)
    -> Eff es r)
-> Eff es r
withLiftMapIO !LocalEnv localEs handlerEs
_ (forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b)
-> Eff es r
k = (forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b)
-> Eff es r
k ((forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b)
 -> Eff es r)
-> (forall a b. (IO a -> IO b) -> Eff localEs a -> Eff localEs b)
-> Eff es r
forall a b. (a -> b) -> a -> b
$ \IO a -> IO b
mapIO Eff localEs a
m -> (Env localEs -> IO b) -> Eff localEs b
forall (es :: [Effect]) a. (Env es -> IO a) -> Eff es a
unsafeEff ((Env localEs -> IO b) -> Eff localEs b)
-> (Env localEs -> IO b) -> Eff localEs b
forall a b. (a -> b) -> a -> b
$ \Env localEs
es -> do
  -- The LocalEnv parameter is not used, but we need it to constraint the
  -- localEs type variable. It's also strict so that callers don't cheat.
  Env localEs -> ((forall r. Eff localEs r -> IO r) -> IO b) -> IO b
forall (es :: [Effect]) a.
HasCallStack =>
Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
seqUnliftIO Env localEs
es (((forall r. Eff localEs r -> IO r) -> IO b) -> IO b)
-> ((forall r. Eff localEs r -> IO r) -> IO b) -> IO b
forall a b. (a -> b) -> a -> b
$ \forall r. Eff localEs r -> IO r
unlift -> IO a -> IO b
mapIO (IO a -> IO b) -> IO a -> IO b
forall a b. (a -> b) -> a -> b
$ Eff localEs a -> IO a
forall r. Eff localEs r -> IO r
unlift Eff localEs a
m

----------------------------------------
-- Bidirectional lifts

-- | Create a local lifting and unlifting function with the given strategy.
--
-- Useful for lifting complicated 'Eff' computations where the monadic action
-- shows in both positive (as a result) and negative (as an argument) position.
--
-- /Note:/ depending on the computation you're lifting 'localUnlift' along with
-- 'withLiftMap' might be enough and is more efficient.
localLiftUnlift
  :: (HasCallStack, SuffixOf es handlerEs)
  => LocalEnv localEs handlerEs
  -- ^ Local environment.
  -> UnliftStrategy
  -> ((forall r. Eff es r -> Eff localEs r) -> (forall r. Eff localEs r -> Eff es r) -> Eff es a)
  -- ^ Continuation with the lifting and unlifting function in scope.
  -> Eff es a
localLiftUnlift :: forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) a.
(HasCallStack, SuffixOf es handlerEs) =>
LocalEnv localEs handlerEs
-> UnliftStrategy
-> ((forall r. Eff es r -> Eff localEs r)
    -> (forall r. Eff localEs r -> Eff es r) -> Eff es a)
-> Eff es a
localLiftUnlift (LocalEnv Env localEs
les) UnliftStrategy
strategy (forall r. Eff es r -> Eff localEs r)
-> (forall r. Eff localEs r -> Eff es r) -> Eff es a
k = case UnliftStrategy
strategy of
  UnliftStrategy
SeqUnlift -> (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
es -> do
    Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
seqUnliftIO Env es
es (((forall r. Eff es r -> IO r) -> IO a) -> IO a)
-> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall r. Eff es r -> IO r
unliftEs -> do
      Env localEs -> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
seqUnliftIO Env localEs
les (((forall r. Eff localEs r -> IO r) -> IO a) -> IO a)
-> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall r. Eff localEs r -> IO r
unliftLocalEs -> do
        (Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es) (Eff es a -> IO a) -> Eff es a -> IO a
forall a b. (a -> b) -> a -> b
$ (forall r. Eff es r -> Eff localEs r)
-> (forall r. Eff localEs r -> Eff es r) -> Eff es a
k (IO r -> Eff localEs r
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_ (IO r -> Eff localEs r)
-> (Eff es r -> IO r) -> Eff es r -> Eff localEs r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff es r -> IO r
forall r. Eff es r -> IO r
unliftEs) (IO r -> Eff es r
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_ (IO r -> Eff es r)
-> (Eff localEs r -> IO r) -> Eff localEs r -> Eff es r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff localEs r -> IO r
forall r. Eff localEs r -> IO r
unliftLocalEs)
  ConcUnlift Persistence
p Limit
l -> (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
es -> do
    Env es
-> Persistence
-> Limit
-> ((forall r. Eff es r -> IO r) -> IO a)
-> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es
-> Persistence
-> Limit
-> ((forall r. Eff es r -> IO r) -> IO a)
-> IO a
concUnliftIO Env es
es Persistence
p Limit
l (((forall r. Eff es r -> IO r) -> IO a) -> IO a)
-> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall r. Eff es r -> IO r
unliftEs -> do
      Env localEs
-> Persistence
-> Limit
-> ((forall r. Eff localEs r -> IO r) -> IO a)
-> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es
-> Persistence
-> Limit
-> ((forall r. Eff es r -> IO r) -> IO a)
-> IO a
concUnliftIO Env localEs
les Persistence
p Limit
l (((forall r. Eff localEs r -> IO r) -> IO a) -> IO a)
-> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \forall r. Eff localEs r -> IO r
unliftLocalEs -> do
        (Eff es a -> Env es -> IO a
forall (es :: [Effect]) a. Eff es a -> Env es -> IO a
`unEff` Env es
es) (Eff es a -> IO a) -> Eff es a -> IO a
forall a b. (a -> b) -> a -> b
$ (forall r. Eff es r -> Eff localEs r)
-> (forall r. Eff localEs r -> Eff es r) -> Eff es a
k (IO r -> Eff localEs r
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_ (IO r -> Eff localEs r)
-> (Eff es r -> IO r) -> Eff es r -> Eff localEs r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff es r -> IO r
forall r. Eff es r -> IO r
unliftEs) (IO r -> Eff es r
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_ (IO r -> Eff es r)
-> (Eff localEs r -> IO r) -> Eff localEs r -> Eff es r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Eff localEs r -> IO r
forall r. Eff localEs r -> IO r
unliftLocalEs)

-- | Create a local unlifting function with the given strategy along with an
-- unrestricted lifting function.
--
-- Useful for lifting complicated 'IO' computations where the monadic action
-- shows in both positive (as a result) and negative (as an argument) position.
--
-- /Note:/ depending on the computation you're lifting 'localUnliftIO' along
-- with 'withLiftMapIO' might be enough and is more efficient.
localLiftUnliftIO
  :: (HasCallStack, SuffixOf es handlerEs, IOE :> es)
  => LocalEnv localEs handlerEs
  -- ^ Local environment.
  -> UnliftStrategy
  -> ((forall r. IO r -> Eff localEs r) -> (forall r. Eff localEs r -> IO r) -> IO a)
  -- ^ Continuation with the lifting and unlifting function in scope.
  -> Eff es a
localLiftUnliftIO :: forall (es :: [Effect]) (handlerEs :: [Effect])
       (localEs :: [Effect]) a.
(HasCallStack, SuffixOf es handlerEs, IOE :> es) =>
LocalEnv localEs handlerEs
-> UnliftStrategy
-> ((forall r. IO r -> Eff localEs r)
    -> (forall r. Eff localEs r -> IO r) -> IO a)
-> Eff es a
localLiftUnliftIO (LocalEnv Env localEs
les) UnliftStrategy
strategy (forall r. IO r -> Eff localEs r)
-> (forall r. Eff localEs r -> IO r) -> IO a
k = case UnliftStrategy
strategy of
  UnliftStrategy
SeqUnlift      -> IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Env localEs -> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es -> ((forall r. Eff es r -> IO r) -> IO a) -> IO a
seqUnliftIO Env localEs
les (((forall r. Eff localEs r -> IO r) -> IO a) -> IO a)
-> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (forall r. IO r -> Eff localEs r)
-> (forall r. Eff localEs r -> IO r) -> IO a
k forall r. IO r -> Eff localEs r
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_
  ConcUnlift Persistence
p Limit
l -> IO a -> Eff es a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a) -> IO a -> Eff es a
forall a b. (a -> b) -> a -> b
$ Env localEs
-> Persistence
-> Limit
-> ((forall r. Eff localEs r -> IO r) -> IO a)
-> IO a
forall (es :: [Effect]) a.
HasCallStack =>
Env es
-> Persistence
-> Limit
-> ((forall r. Eff es r -> IO r) -> IO a)
-> IO a
concUnliftIO Env localEs
les Persistence
p Limit
l (((forall r. Eff localEs r -> IO r) -> IO a) -> IO a)
-> ((forall r. Eff localEs r -> IO r) -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ (forall r. IO r -> Eff localEs r)
-> (forall r. Eff localEs r -> IO r) -> IO a
k forall r. IO r -> Eff localEs r
forall a (es :: [Effect]). IO a -> Eff es a
unsafeEff_

----------------------------------------
-- Utils

-- | Require that the second list of effects is a suffix of the first one.
--
-- In other words, 'SuffixOf' @es@ @baseEs@ means "a suffix of @es@ is
-- @baseEs@".
type family SuffixOf (es :: [Effect]) (baseEs :: [Effect]) :: Constraint where
  SuffixOf   baseEs baseEs = ()
  SuffixOf (e : es) baseEs = SuffixOf es baseEs

-- $setup
-- >>> import Control.Concurrent (ThreadId, forkIOWithUnmask)