{-# LANGUAGE AllowAmbiguousTypes #-}

module Polysemy.IO
  ( -- * Interpretations
    embedToMonadIO
  , lowerEmbedded
  ) where

import Control.Monad.IO.Class
import Polysemy
import Polysemy.Embed
import Polysemy.Internal
import Polysemy.Internal.Union


------------------------------------------------------------------------------
-- The 'MonadIO' class is conceptually an interpretation of 'IO' to some
-- other monad. This function reifies that intuition, by transforming an 'IO'
-- effect into some other 'MonadIO'.
--
-- This function is especially useful when using the 'MonadIO' instance for
-- 'Sem' instance.
--
-- Make sure to type-apply the desired 'MonadIO' instance when using
-- 'embedToMonadIO'.
--
-- @since 1.0.0.0
--
-- ==== Example
--
-- @
-- foo :: PandocIO ()
-- foo = 'runM' . 'embedToMonadIO' @PandocIO $ do
--   'liftIO' $ putStrLn "hello from polysemy"
-- @
--
embedToMonadIO
    :: forall m r a
     . ( MonadIO m
       , Member (Embed m) r
       )
    => Sem (Embed IO ': r) a
    -> Sem r a
embedToMonadIO :: Sem (Embed IO : r) a -> Sem r a
embedToMonadIO = (forall x. IO x -> m x) -> Sem (Embed IO : r) a -> Sem r a
forall (m1 :: * -> *) (m2 :: * -> *) (r :: EffectRow) a.
Member (Embed m2) r =>
(forall x. m1 x -> m2 x) -> Sem (Embed m1 : r) a -> Sem r a
runEmbedded ((forall x. IO x -> m x) -> Sem (Embed IO : r) a -> Sem r a)
-> (forall x. IO x -> m x) -> Sem (Embed IO : r) a -> Sem r a
forall a b. (a -> b) -> a -> b
$ forall x. MonadIO m => IO x -> m x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO @m
{-# INLINE embedToMonadIO #-}


------------------------------------------------------------------------------
-- | Given some @'MonadIO' m@, interpret all @'Embed' m@ actions in that monad
-- at once. This is useful for interpreting effects like databases, which use
-- their own monad for describing actions.
--
-- This function creates a thread, and so should be compiled with @-threaded@.
--
-- @since 1.0.0.0
lowerEmbedded
    :: ( MonadIO m
       , Member (Embed IO) r
       )
    => (forall x. m x -> IO x)  -- ^ The means of running this monad.
    -> Sem (Embed m ': r) a
    -> Sem r a
lowerEmbedded :: (forall x. m x -> IO x) -> Sem (Embed m : r) a -> Sem r a
lowerEmbedded forall x. m x -> IO x
run_m (Sem forall (m :: * -> *).
Monad m =>
(forall x. Union (Embed m : r) (Sem (Embed m : r)) x -> m x) -> m a
m) = ((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
forall (r :: EffectRow) a.
Member (Embed IO) r =>
((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
withLowerToIO (((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a)
-> ((forall x. Sem r x -> IO x) -> IO () -> IO a) -> Sem r a
forall a b. (a -> b) -> a -> b
$ \forall x. Sem r x -> IO x
lower IO ()
_ ->
  m a -> IO a
forall x. m x -> IO x
run_m (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ (forall x. Union (Embed m : r) (Sem (Embed m : r)) x -> m x) -> m a
forall (m :: * -> *).
Monad m =>
(forall x. Union (Embed m : r) (Sem (Embed m : r)) x -> m x) -> m a
m ((forall x. Union (Embed m : r) (Sem (Embed m : r)) x -> m x)
 -> m a)
-> (forall x. Union (Embed m : r) (Sem (Embed m : r)) x -> m x)
-> m a
forall a b. (a -> b) -> a -> b
$ \Union (Embed m : r) (Sem (Embed m : r)) x
u ->
    case Union (Embed m : r) (Sem (Embed m : r)) x
-> Either
     (Union r (Sem (Embed m : r)) x)
     (Weaving (Embed m) (Sem (Embed m : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (Embed m : r) (Sem (Embed m : r)) x
u of
      Left Union r (Sem (Embed m : r)) x
x -> IO x -> m x
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
              (IO x -> m x)
-> (Union r (Sem r) x -> IO x) -> Union r (Sem r) x -> m x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r x -> IO x
forall x. Sem r x -> IO x
lower
              (Sem r x -> IO x)
-> (Union r (Sem r) x -> Sem r x) -> Union r (Sem r) x -> IO x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Union r (Sem r) x -> Sem r x
forall (r :: EffectRow) a. Union r (Sem r) a -> Sem r a
liftSem
              (Union r (Sem r) x -> m x) -> Union r (Sem r) x -> m x
forall a b. (a -> b) -> a -> b
$ (forall x. Sem (Embed m : r) x -> Sem r x)
-> Union r (Sem (Embed m : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist ((forall x. m x -> IO x) -> Sem (Embed m : r) x -> Sem r x
forall (m :: * -> *) (r :: EffectRow) a.
(MonadIO m, Member (Embed IO) r) =>
(forall x. m x -> IO x) -> Sem (Embed m : r) a -> Sem r a
lowerEmbedded forall x. m x -> IO x
run_m) Union r (Sem (Embed m : r)) x
x

      Right (Weaving (Embed m a
wd) f ()
s forall x. f (Sem rInitial x) -> Sem (Embed m : r) (f x)
_ f a -> x
y forall x. f x -> Maybe x
_) ->
        f a -> x
y (f a -> x) -> m (f a) -> m x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s) (a -> f a) -> m a -> m (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
wd)