{-# LANGUAGE AllowAmbiguousTypes, TemplateHaskell #-}

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 :: 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
forall (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 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 (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 (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 -> 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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s
{-# INLINE fixpointToFinal #-}

------------------------------------------------------------------------------
-- | Run a 'Fixpoint' effect purely.
--
-- __Note__: 'runFixpoint' is subject to the same caveats as 'fixpointToFinal'.
runFixpoint
    :: (∀ x. Sem r x -> x)
    -> Sem (Fixpoint ': r) a
    -> Sem r a
runFixpoint :: (forall x. Sem r x -> x) -> Sem (Fixpoint : r) a -> Sem r a
runFixpoint forall x. Sem r x -> x
lower = (forall x (rInitial :: EffectRow).
 Fixpoint (Sem rInitial) x -> Tactical Fixpoint (Sem rInitial) r x)
-> Sem (Fixpoint : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH ((forall x (rInitial :: EffectRow).
  Fixpoint (Sem rInitial) x -> Tactical Fixpoint (Sem rInitial) r x)
 -> Sem (Fixpoint : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Fixpoint (Sem rInitial) x -> Tactical Fixpoint (Sem rInitial) r x)
-> Sem (Fixpoint : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Fixpoint mf -> do
    f x -> Sem (Fixpoint : r) (f x)
c   <- (x -> Sem rInitial x)
-> Sem
     (WithTactics Fixpoint f (Sem rInitial) r)
     (f x -> Sem (Fixpoint : r) (f x))
forall a (m :: * -> *) b (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: EffectRow).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT x -> Sem rInitial x
mf
    f ()
s   <- Sem (WithTactics Fixpoint f (Sem rInitial) r) (f ())
forall (f :: * -> *) (m :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *).
Sem (WithTactics e f m r) (f ())
getInitialStateT
    Inspector f
ins <- Sem (WithTactics Fixpoint f (Sem rInitial) r) (Inspector f)
forall (e :: (* -> *) -> * -> *) (f :: * -> *) (m :: * -> *)
       (r :: EffectRow).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
    f x -> Sem (WithTactics Fixpoint f (Sem rInitial) r) (f x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f x -> Sem (WithTactics Fixpoint f (Sem rInitial) r) (f x))
-> f x -> Sem (WithTactics Fixpoint f (Sem rInitial) r) (f x)
forall a b. (a -> b) -> a -> b
$ (f x -> f x) -> f x
forall a. (a -> a) -> a
fix ((f x -> f x) -> f x) -> (f x -> f x) -> f x
forall a b. (a -> b) -> a -> b
$ \f x
fa ->
      Sem r (f x) -> f x
forall x. Sem r x -> x
lower (Sem r (f x) -> f x) -> (f x -> Sem r (f x)) -> f x -> f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Sem r x -> x) -> Sem (Fixpoint : r) (f x) -> Sem r (f x)
forall (r :: EffectRow) a.
(forall x. Sem r x -> x) -> Sem (Fixpoint : r) a -> Sem r a
runFixpoint forall x. Sem r x -> x
lower (Sem (Fixpoint : r) (f x) -> Sem r (f x))
-> (f x -> Sem (Fixpoint : r) (f x)) -> f x -> Sem r (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> Sem (Fixpoint : r) (f x)
c (f x -> f x) -> f x -> 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
"runFixpoint") (Inspector f -> 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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s
{-# INLINE runFixpoint #-}
{-# DEPRECATED runFixpoint "Use 'fixpointToFinal' together with \
                           \'Data.Functor.Identity.Identity' instead" #-}


------------------------------------------------------------------------------
-- | Run a 'Fixpoint' effect in terms of an underlying 'MonadFix' instance.
--
-- __Note__: 'runFixpointM' is subject to the same caveats as 'fixpointToFinal'.
runFixpointM
    :: ( MonadFix m
       , Member (Embed m) r
       )
    => (∀ x. Sem r x -> m x)
    -> Sem (Fixpoint ': r) a
    -> Sem r a
runFixpointM :: (forall x. Sem r x -> m x) -> Sem (Fixpoint : r) a -> Sem r a
runFixpointM forall x. Sem r x -> m x
lower = (forall x (rInitial :: EffectRow).
 Fixpoint (Sem rInitial) x -> Tactical Fixpoint (Sem rInitial) r x)
-> Sem (Fixpoint : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
(forall x (rInitial :: EffectRow).
 e (Sem rInitial) x -> Tactical e (Sem rInitial) r x)
-> Sem (e : r) a -> Sem r a
interpretH ((forall x (rInitial :: EffectRow).
  Fixpoint (Sem rInitial) x -> Tactical Fixpoint (Sem rInitial) r x)
 -> Sem (Fixpoint : r) a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Fixpoint (Sem rInitial) x -> Tactical Fixpoint (Sem rInitial) r x)
-> Sem (Fixpoint : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Fixpoint mf -> do
    f x -> Sem (Fixpoint : r) (f x)
c   <- (x -> Sem rInitial x)
-> Sem
     (WithTactics Fixpoint f (Sem rInitial) r)
     (f x -> Sem (Fixpoint : r) (f x))
forall a (m :: * -> *) b (e :: (* -> *) -> * -> *) (f :: * -> *)
       (r :: EffectRow).
(a -> m b) -> Sem (WithTactics e f m r) (f a -> Sem (e : r) (f b))
bindT x -> Sem rInitial x
mf
    f ()
s   <- Sem (WithTactics Fixpoint f (Sem rInitial) r) (f ())
forall (f :: * -> *) (m :: * -> *) (r :: EffectRow)
       (e :: (* -> *) -> * -> *).
Sem (WithTactics e f m r) (f ())
getInitialStateT
    Inspector f
ins <- Sem (WithTactics Fixpoint f (Sem rInitial) r) (Inspector f)
forall (e :: (* -> *) -> * -> *) (f :: * -> *) (m :: * -> *)
       (r :: EffectRow).
Sem (WithTactics e f m r) (Inspector f)
getInspectorT
    m (f x) -> Sem (WithTactics Fixpoint f (Sem rInitial) r) (f x)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (m (f x) -> Sem (WithTactics Fixpoint f (Sem rInitial) r) (f x))
-> m (f x) -> Sem (WithTactics Fixpoint f (Sem rInitial) r) (f x)
forall a b. (a -> b) -> a -> b
$ (f x -> m (f x)) -> m (f x)
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 ->
      Sem r (f x) -> m (f x)
forall x. Sem r x -> m x
lower (Sem r (f x) -> m (f x)) -> (f x -> Sem r (f x)) -> f x -> m (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. Sem r x -> m x)
-> Sem (Fixpoint : r) (f x) -> Sem r (f x)
forall (m :: * -> *) (r :: EffectRow) a.
(MonadFix m, Member (Embed m) r) =>
(forall x. Sem r x -> m x) -> Sem (Fixpoint : r) a -> Sem r a
runFixpointM forall x. Sem r x -> m x
lower (Sem (Fixpoint : r) (f x) -> Sem r (f x))
-> (f x -> Sem (Fixpoint : r) (f x)) -> f x -> Sem r (f x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> Sem (Fixpoint : r) (f x)
c (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
"runFixpointM") (Inspector f -> 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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s
{-# INLINE runFixpointM #-}
{-# DEPRECATED runFixpointM "Use 'fixpointToFinal' instead" #-}