Internal.hs

{-# 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 f sem = withWeavingToFinal $ \s wv ins -> do
  st  <- newMVar s
  res <- runMaybeT $ runViaFinalGlobal st wv ins f sem
  s'  <- readMVar st
  return (fromMaybe bomb res <$ 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 st wv ins f = usingSem $ \u -> case decomp u of
  Right (Weaving e s' wv' ex ins') ->
    fmap ex $ MaybeT $ fmap getCompose $ runStrategy (f e)
          (Compose (Just s'))
          (  maybe
              (pure (Compose Nothing))
              (  fmap Compose
               . runMaybeT
               . runViaFinalGlobal st wv ins f
               . wv'
              )
           . getCompose
          )
          (getCompose >=> ins')
  Left g -> case prj g of
      Just (Weaving (WithWeavingToFinal wav) s' wv' ex' ins') ->
        MaybeT $ fmap (fmap ex' . getCompose) $
          wav
            (Compose (Just s'))
            (  maybe
                (pure (Compose Nothing))
                ( fmap Compose
                . runMaybeT
                . runViaFinalGlobal st wv ins f
                . wv'
                )
             . getCompose
            )
            (getCompose >=> ins')
      _ -> MaybeT $ mask $ \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.
        s   <- takeMVar st
        res <- restore (wv (liftSem (hoist (interpretFinalGlobal f) g) <$ s))
          `onException` putMVar st s
        putMVar st (() <$ res)
        return $ ins res
{-# INLINE runViaFinalGlobal #-}

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