{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-}

-- | Description: Interpreters for 'Fixpoint'
module Polysemy.Fixpoint
  ( -- * Effect
    Fixpoint (..)

    -- * Interpretations
  , module Polysemy.Fixpoint
  ) where

import Control.Monad.Fix
import Data.Maybe

import Polysemy
import Polysemy.Final
import Polysemy.Internal.Fixpoint

-----------------------------------------------------------------------------
-- | Run a 'Fixpoint' effect in terms of a final 'MonadFix' instance.
--
-- If you need to run a 'Fixpoint' effect purely, use this together with
-- @'Final' 'Data.Functor.Identity.Identity'@.
--
-- __Note__: This is subject to the same traps as 'MonadFix' instances for
-- monads with failure: this will throw an exception if you try to recursively use
-- the result of a failed computation in an action whose effect may be observed
-- even though the computation failed.
--
-- For example, the following program will throw an exception upon evaluating the
-- final state:
--
-- @
-- bad :: (Int, Either () Int)
-- bad =
--    'Data.Functor.Identity.runIdentity'
--  . 'runFinal'
--  . 'fixpointToFinal' \@'Data.Functor.Identity.Identity'
--  . 'Polysemy.State.runLazyState' \@Int 1
--  . 'Polysemy.Error.runError'
--  $ mdo
--   'Polysemy.State.put' a
--   a <- 'Polysemy.Error.throw' ()
--   return a
-- @
--
-- 'fixpointToFinal' also 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.Error.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@.
--
-- This assumption holds true for all interpreters featured in this package,
-- and is presumably always true for any properly implemented interpreter.
-- 'fixpointToFinal' may throw an exception if it is used together with an
-- interpreter that uses 'Polysemy.Internal.Union.weave' improperly.
--
-- If 'fixpointToFinal' throws an exception for you, and it can't
-- be due to any of the above, then open an issue over at the
-- GitHub repository for polysemy.
--
-- @since 1.2.0.0
fixpointToFinal :: forall m r a
                 . (Member (Final m) r, MonadFix m)
                => Sem (Fixpoint ': r) a
                -> Sem r a
fixpointToFinal :: forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, MonadFix m) =>
Sem (Fixpoint : r) a -> Sem r a
fixpointToFinal = forall (m :: * -> *) (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Final m) r =>
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (e : r) a -> Sem r a
interpretFinal @m ((forall x (rInitial :: EffectRow).
  Fixpoint (Sem rInitial) x -> Strategic m (Sem rInitial) x)
 -> Sem (Fixpoint : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Fixpoint (Sem rInitial) x -> Strategic m (Sem rInitial) x)
-> Sem (Fixpoint : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$
  \(Fixpoint x -> Sem rInitial x
f) -> do
    f x -> m (f x)
f'  <- (x -> Sem rInitial x)
-> Sem (WithStrategy m f (Sem rInitial)) (f x -> m (f x))
forall a (n :: * -> *) b (m :: * -> *) (f :: * -> *).
(a -> n b) -> Sem (WithStrategy m f n) (f a -> m (f b))
bindS x -> Sem rInitial x
f
    f ()
s   <- Sem (WithStrategy m f (Sem rInitial)) (f ())
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (f ())
getInitialStateS
    Inspector f
ins <- Sem (WithStrategy m f (Sem rInitial)) (Inspector f)
forall (m :: * -> *) (f :: * -> *) (n :: * -> *).
Sem (WithStrategy m f n) (Inspector f)
getInspectorS
    m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a. a -> Sem (WithStrategy m f (Sem rInitial)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x)))
-> m (f x) -> Sem (WithStrategy m f (Sem rInitial)) (m (f x))
forall a b. (a -> b) -> a -> b
$ (f x -> m (f x)) -> m (f x)
forall a. (a -> m a) -> m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((f x -> m (f x)) -> m (f x)) -> (f x -> m (f x)) -> m (f x)
forall a b. (a -> b) -> a -> b
$ \f x
fa -> f x -> m (f x)
f' (f x -> m (f x)) -> f x -> m (f x)
forall a b. (a -> b) -> a -> b
$
      x -> Maybe x -> x
forall a. a -> Maybe a -> a
fromMaybe (String -> x
forall a. String -> a
bomb String
"fixpointToFinal") (Inspector f -> forall x. f x -> Maybe x
forall (f :: * -> *). Inspector f -> forall x. f x -> Maybe x
inspect Inspector f
ins f x
fa) x -> f () -> f x
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s
{-# INLINE fixpointToFinal #-}