{-# LANGUAGE TemplateHaskell #-}
module Polysemy.Final.IO.Internal where

import Data.Functor.Compose
import Data.Maybe

import Control.Concurrent.MVar
import Control.Exception
import Control.Monad
import Control.Monad.Trans.Maybe

import Polysemy
import Polysemy.Final
import Polysemy.Internal
import Polysemy.Internal.Union
import Polysemy.Internal.Strategy

------------------------------------------------------------------------------
-- | Like 'interpretFinal' specialized to 'IO', but also tries very hard
-- to preserve state semantics dependant on the order interpreters are run,
-- adressing the primary issue with 'Final'.
--
-- Semantically, interpreters written using this behave very much as
-- though they were written using 'withLowerToIO'.
-- However, this does not need to spawn an interpreter thread, making
-- it more efficient (but not any more safe.)
--
-- 'interpretFinalGlobal' operates under the assumption that any effectful
-- state which can't be inspected using 'Polysemy.Inspector' can't contain any
-- values. For example, the effectful state for 'Polysemy.runError' is
-- @'Either' e a@. The inspector for this effectful state only fails if the
-- effectful state is a @'Left'@ value, which therefore doesn't contain any
-- values of @a@.
--
-- The assumption holds true for all interpreters featured in polysemy,
-- and is presumably always true for any properly implemented interpreter.
-- 'interpretFinalGlobal' may throw an exception if it is used together with an
-- interpreter that uses 'Polysemy.Internal.Union.weave' improperly.
interpretFinalGlobal
    :: forall e a r
     . Member (Final IO) r
    => (forall x n. e n x -> Strategic IO n x)
    -> Sem (e ': r) a
    -> Sem r a
interpretFinalGlobal :: (forall x (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) a -> Sem r a
interpretFinalGlobal forall x (n :: * -> *). e n x -> Strategic IO n x
f Sem (e : r) a
sem = ThroughWeavingToFinal IO (Sem r) a -> Sem r a
forall (m :: * -> *) (r :: EffectRow) a.
Member (Final m) r =>
ThroughWeavingToFinal m (Sem r) a -> Sem r a
withWeavingToFinal (ThroughWeavingToFinal IO (Sem r) a -> Sem r a)
-> ThroughWeavingToFinal IO (Sem r) a -> Sem r a
forall a b. (a -> b) -> a -> b
$ \f ()
s forall x. f (Sem r x) -> IO (f x)
wv forall x. f x -> Maybe x
ins -> do
  MVar (f ())
st  <- f () -> IO (MVar (f ()))
forall a. a -> IO (MVar a)
newMVar f ()
s
  Maybe a
res <- MaybeT IO a -> IO (Maybe a)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT IO a -> IO (Maybe a)) -> MaybeT IO a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ MVar (f ())
-> (forall x. f (Sem r x) -> IO (f x))
-> (forall x. f x -> Maybe x)
-> (forall x (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) a
-> MaybeT IO a
forall (r :: EffectRow) (f :: * -> *) (e :: Effect) a.
(Member (Final IO) r, Functor f) =>
MVar (f ())
-> (forall x. f (Sem r x) -> IO (f x))
-> (forall x. f x -> Maybe x)
-> (forall x (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) a
-> MaybeT IO a
runViaFinalGlobal MVar (f ())
st forall x. f (Sem r x) -> IO (f x)
wv forall x. f x -> Maybe x
ins forall x (n :: * -> *). e n x -> Strategic IO n x
f Sem (e : r) a
sem
  f ()
s'  <- MVar (f ()) -> IO (f ())
forall a. MVar a -> IO a
readMVar MVar (f ())
st
  f a -> IO (f a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
forall a. a
bomb Maybe a
res a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s')
{-# INLINE interpretFinalGlobal #-}

runViaFinalGlobal :: (Member (Final IO) r, Functor f)
                  => MVar (f ())
                  -> (forall x. f (Sem r x) -> IO (f x))
                  -> (forall x. f x -> Maybe x)
                  -> ( forall x n
                     . e n x
                    -> Strategic IO n x
                     )
                  -> Sem (e ': r) a
                  -> MaybeT IO a
runViaFinalGlobal :: MVar (f ())
-> (forall x. f (Sem r x) -> IO (f x))
-> (forall x. f x -> Maybe x)
-> (forall x (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) a
-> MaybeT IO a
runViaFinalGlobal MVar (f ())
st forall x. f (Sem r x) -> IO (f x)
wv forall x. f x -> Maybe x
ins forall x (n :: * -> *). e n x -> Strategic IO n x
f = (forall x. Union (e : r) (Sem (e : r)) x -> MaybeT IO x)
-> Sem (e : r) a -> MaybeT IO a
forall (m :: * -> *) (r :: EffectRow) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem ((forall x. Union (e : r) (Sem (e : r)) x -> MaybeT IO x)
 -> Sem (e : r) a -> MaybeT IO a)
-> (forall x. Union (e : r) (Sem (e : r)) x -> MaybeT IO x)
-> Sem (e : r) a
-> MaybeT IO a
forall a b. (a -> b) -> a -> b
$ \Union (e : r) (Sem (e : r)) x
u -> case Union (e : r) (Sem (e : r)) x
-> Either (Union r (Sem (e : r)) x) (Weaving e (Sem (e : r)) x)
forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (e : r) (Sem (e : r)) x
u of
  Right (Weaving e (Sem rInitial) a
e f ()
s' forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv' f a -> x
ex forall x. f x -> Maybe x
ins') ->
    (f a -> x) -> MaybeT IO (f a) -> MaybeT IO x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> x
ex (MaybeT IO (f a) -> MaybeT IO x) -> MaybeT IO (f a) -> MaybeT IO x
forall a b. (a -> b) -> a -> b
$ IO (Maybe (f a)) -> MaybeT IO (f a)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe (f a)) -> MaybeT IO (f a))
-> IO (Maybe (f a)) -> MaybeT IO (f a)
forall a b. (a -> b) -> a -> b
$ (Compose Maybe f a -> Maybe (f a))
-> IO (Compose Maybe f a) -> IO (Maybe (f a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Compose Maybe f a -> Maybe (f a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (IO (Compose Maybe f a) -> IO (Maybe (f a)))
-> IO (Compose Maybe f a) -> IO (Maybe (f a))
forall a b. (a -> b) -> a -> b
$ Sem
  '[Strategy IO (Compose Maybe f) (Sem rInitial)]
  (IO (Compose Maybe f a))
-> Compose Maybe f ()
-> (forall x.
    Compose Maybe f (Sem rInitial x) -> IO (Compose Maybe f x))
-> (forall x. Compose Maybe f x -> Maybe x)
-> IO (Compose Maybe f a)
forall (f :: * -> *) (m :: * -> *) (n :: * -> *) a.
Functor f =>
Sem '[Strategy m f n] a
-> f ()
-> (forall x. f (n x) -> m (f x))
-> (forall x. f x -> Maybe x)
-> a
runStrategy (e (Sem rInitial) a -> Strategic IO (Sem rInitial) a
forall x (n :: * -> *). e n x -> Strategic IO n x
f e (Sem rInitial) a
e)
          (Maybe (f ()) -> Compose Maybe f ()
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (f () -> Maybe (f ())
forall a. a -> Maybe a
Just f ()
s'))
          (  IO (Compose Maybe f x)
-> (f (Sem rInitial x) -> IO (Compose Maybe f x))
-> Maybe (f (Sem rInitial x))
-> IO (Compose Maybe f x)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
              (Compose Maybe f x -> IO (Compose Maybe f x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (f x) -> Compose Maybe f x
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Maybe (f x)
forall a. Maybe a
Nothing))
              (  (Maybe (f x) -> Compose Maybe f x)
-> IO (Maybe (f x)) -> IO (Compose Maybe f x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (f x) -> Compose Maybe f x
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose
               (IO (Maybe (f x)) -> IO (Compose Maybe f x))
-> (f (Sem rInitial x) -> IO (Maybe (f x)))
-> f (Sem rInitial x)
-> IO (Compose Maybe f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT IO (f x) -> IO (Maybe (f x))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
               (MaybeT IO (f x) -> IO (Maybe (f x)))
-> (f (Sem rInitial x) -> MaybeT IO (f x))
-> f (Sem rInitial x)
-> IO (Maybe (f x))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (f ())
-> (forall x. f (Sem r x) -> IO (f x))
-> (forall x. f x -> Maybe x)
-> (forall x (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) (f x)
-> MaybeT IO (f x)
forall (r :: EffectRow) (f :: * -> *) (e :: Effect) a.
(Member (Final IO) r, Functor f) =>
MVar (f ())
-> (forall x. f (Sem r x) -> IO (f x))
-> (forall x. f x -> Maybe x)
-> (forall x (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) a
-> MaybeT IO a
runViaFinalGlobal MVar (f ())
st forall x. f (Sem r x) -> IO (f x)
wv forall x. f x -> Maybe x
ins forall x (n :: * -> *). e n x -> Strategic IO n x
f
               (Sem (e : r) (f x) -> MaybeT IO (f x))
-> (f (Sem rInitial x) -> Sem (e : r) (f x))
-> f (Sem rInitial x)
-> MaybeT IO (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> Sem (e : r) (f x)
forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv'
              )
           (Maybe (f (Sem rInitial x)) -> IO (Compose Maybe f x))
-> (Compose Maybe f (Sem rInitial x) -> Maybe (f (Sem rInitial x)))
-> Compose Maybe f (Sem rInitial x)
-> IO (Compose Maybe f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose Maybe f (Sem rInitial x) -> Maybe (f (Sem rInitial x))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose
          )
          (Compose Maybe f x -> Maybe (f x)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose Maybe f x -> Maybe (f x))
-> (f x -> Maybe x) -> Compose Maybe f x -> Maybe x
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> f x -> Maybe x
forall x. f x -> Maybe x
ins')
  Left Union r (Sem (e : r)) x
g -> case Union r (Sem (e : r)) x
-> Maybe (Weaving (Final IO) (Sem (e : r)) x)
forall (e :: Effect) (r :: EffectRow) (m :: * -> *) a.
Member e r =>
Union r m a -> Maybe (Weaving e m a)
prj Union r (Sem (e : r)) x
g of
      Just (Weaving (WithWeavingToFinal wav) f ()
s' forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv' f a -> x
ex' forall x. f x -> Maybe x
ins') ->
        IO (Maybe x) -> MaybeT IO x
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe x) -> MaybeT IO x) -> IO (Maybe x) -> MaybeT IO x
forall a b. (a -> b) -> a -> b
$ (Compose Maybe f a -> Maybe x)
-> IO (Compose Maybe f a) -> IO (Maybe x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f a -> x) -> Maybe (f a) -> Maybe x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> x
ex' (Maybe (f a) -> Maybe x)
-> (Compose Maybe f a -> Maybe (f a))
-> Compose Maybe f a
-> Maybe x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose Maybe f a -> Maybe (f a)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose) (IO (Compose Maybe f a) -> IO (Maybe x))
-> IO (Compose Maybe f a) -> IO (Maybe x)
forall a b. (a -> b) -> a -> b
$
          Compose Maybe f ()
-> (forall x.
    Compose Maybe f (Sem rInitial x) -> IO (Compose Maybe f x))
-> (forall x. Compose Maybe f x -> Maybe x)
-> IO (Compose Maybe f a)
ThroughWeavingToFinal IO (Sem rInitial) a
wav
            (Maybe (f ()) -> Compose Maybe f ()
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (f () -> Maybe (f ())
forall a. a -> Maybe a
Just f ()
s'))
            (  IO (Compose Maybe f x)
-> (f (Sem rInitial x) -> IO (Compose Maybe f x))
-> Maybe (f (Sem rInitial x))
-> IO (Compose Maybe f x)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (Compose Maybe f x -> IO (Compose Maybe f x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (f x) -> Compose Maybe f x
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose Maybe (f x)
forall a. Maybe a
Nothing))
                ( (Maybe (f x) -> Compose Maybe f x)
-> IO (Maybe (f x)) -> IO (Compose Maybe f x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe (f x) -> Compose Maybe f x
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose
                (IO (Maybe (f x)) -> IO (Compose Maybe f x))
-> (f (Sem rInitial x) -> IO (Maybe (f x)))
-> f (Sem rInitial x)
-> IO (Compose Maybe f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeT IO (f x) -> IO (Maybe (f x))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT
                (MaybeT IO (f x) -> IO (Maybe (f x)))
-> (f (Sem rInitial x) -> MaybeT IO (f x))
-> f (Sem rInitial x)
-> IO (Maybe (f x))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (f ())
-> (forall x. f (Sem r x) -> IO (f x))
-> (forall x. f x -> Maybe x)
-> (forall x (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) (f x)
-> MaybeT IO (f x)
forall (r :: EffectRow) (f :: * -> *) (e :: Effect) a.
(Member (Final IO) r, Functor f) =>
MVar (f ())
-> (forall x. f (Sem r x) -> IO (f x))
-> (forall x. f x -> Maybe x)
-> (forall x (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) a
-> MaybeT IO a
runViaFinalGlobal MVar (f ())
st forall x. f (Sem r x) -> IO (f x)
wv forall x. f x -> Maybe x
ins forall x (n :: * -> *). e n x -> Strategic IO n x
f
                (Sem (e : r) (f x) -> MaybeT IO (f x))
-> (f (Sem rInitial x) -> Sem (e : r) (f x))
-> f (Sem rInitial x)
-> MaybeT IO (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial x) -> Sem (e : r) (f x)
forall x. f (Sem rInitial x) -> Sem (e : r) (f x)
wv'
                )
             (Maybe (f (Sem rInitial x)) -> IO (Compose Maybe f x))
-> (Compose Maybe f (Sem rInitial x) -> Maybe (f (Sem rInitial x)))
-> Compose Maybe f (Sem rInitial x)
-> IO (Compose Maybe f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compose Maybe f (Sem rInitial x) -> Maybe (f (Sem rInitial x))
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose
            )
            (Compose Maybe f x -> Maybe (f x)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose Maybe f x -> Maybe (f x))
-> (f x -> Maybe x) -> Compose Maybe f x -> Maybe x
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> f x -> Maybe x
forall x. f x -> Maybe x
ins')
      Maybe (Weaving (Final IO) (Sem (e : r)) x)
_ -> IO (Maybe x) -> MaybeT IO x
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (IO (Maybe x) -> MaybeT IO x) -> IO (Maybe x) -> MaybeT IO x
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO (Maybe x)) -> IO (Maybe x)
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO (Maybe x)) -> IO (Maybe x))
-> ((forall a. IO a -> IO a) -> IO (Maybe x)) -> IO (Maybe x)
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        -- TODO(KingoftheHomeless): Figure out a solution to polysemy issue #205.
        -- Although we're using a different mechanism, the exact same problem manifests
        -- here.
        f ()
s   <- MVar (f ()) -> IO (f ())
forall a. MVar a -> IO a
takeMVar MVar (f ())
st
        f x
res <- IO (f x) -> IO (f x)
forall a. IO a -> IO a
restore (f (Sem r x) -> IO (f x)
forall x. f (Sem r x) -> IO (f x)
wv (Union r (Sem r) x -> Sem r x
forall (r :: EffectRow) a. Union r (Sem r) a -> Sem r a
liftSem ((forall x. Sem (e : r) x -> Sem r x)
-> Union r (Sem (e : 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 (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) x -> Sem r x
forall (e :: Effect) a (r :: EffectRow).
Member (Final IO) r =>
(forall x (n :: * -> *). e n x -> Strategic IO n x)
-> Sem (e : r) a -> Sem r a
interpretFinalGlobal forall x (n :: * -> *). e n x -> Strategic IO n x
f) Union r (Sem (e : r)) x
g) Sem r x -> f () -> f (Sem r x)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
          IO (f x) -> IO () -> IO (f x)
forall a b. IO a -> IO b -> IO a
`onException` MVar (f ()) -> f () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (f ())
st f ()
s
        MVar (f ()) -> f () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (f ())
st (() () -> f x -> f ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f x
res)
        Maybe x -> IO (Maybe x)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe x -> IO (Maybe x)) -> Maybe x -> IO (Maybe x)
forall a b. (a -> b) -> a -> b
$ f x -> Maybe x
forall x. f x -> Maybe x
ins f x
res
{-# INLINE runViaFinalGlobal #-}

bomb :: a
bomb :: a
bomb = [Char] -> a
forall a. HasCallStack => [Char] -> a
error
  [Char]
"interpretFinalGlobal: Uninspectable functorial state \
                        \still carried a result. You're likely using an interpreter \
                        \that uses 'weave' improperly. \
                        \See documentation for more information."