{-# LANGUAGE TemplateHaskell, Unsafe #-}
module Polysemy.Cont.Internal where

import Data.Functor.Contravariant

import Polysemy
import Polysemy.Internal
import Polysemy.Internal.Union
import Polysemy.Fresh
import Polysemy.Error

import Control.Monad
import Control.Monad.Trans.Cont hiding (Cont)

import Unsafe.Coerce
import GHC.Exts (Any)

-----------------------------------------------------------------------------
-- | An effect for abortive continuations.
--
-- Formulated à la Tom Schrijvers et al.
-- "Monad Transformers and Modular Algebraic Effects: What Binds Them Together"
-- (2016). <http://www.cs.kuleuven.be/publicaties/rapporten/cw/CW699.pdf>
--
-- Activating polysemy-plugin is highly recommended when using this effect
-- in order to avoid ambiguous types.
data Cont ref m a where
  Jump    :: ref a -> a -> Cont ref m b
  Subst   :: (ref a -> m b) -> (a -> m b) -> Cont ref m b

makeSem_ ''Cont

-----------------------------------------------------------------------------
-- | Provide an answer to a prompt, jumping to its reified continuation,
-- and aborting the current continuation.
--
-- Using 'jump' will rollback all effectful state back to the point where the
-- prompt was created, unless such state is interpreted in terms of the final
-- monad, /or/ the associated interpreter of the effectful state
-- is run after 'runContUnsafe', which may be done if the effect isn't
-- higher-order.
--
-- Higher-order effects do not interact with the continuation in any meaningful
-- way; i.e. 'Polysemy.Reader.local' or 'Polysemy.Writer.censor' does not affect
-- it, and 'Polysemy.Error.catch' will fail to catch any of its exceptions.
-- The only exception to this is if you interpret such effects /and/ 'Cont'
-- in terms of the final monad, and the final monad can perform such interactions
-- in a meaningful manner.
jump :: forall ref a b r.
        Member (Cont ref) r
     => ref a
     -> a
     -> Sem r b

-----------------------------------------------------------------------------
-- | Reifies the current continuation in the form of a prompt, and passes it to
-- the first argument. If the prompt becomes invoked via 'jump', then the
-- second argument will be run before the reified continuation, and otherwise
-- will not be called at all.
subst :: forall ref a b r
      .  Member (Cont ref) r
      => (ref a -> Sem r b)
      -> (a -> Sem r b)
      -> Sem r b

-----------------------------------------------------------------------------
-- | Runs a 'Cont' effect by providing a final continuation.
--
-- __Beware__: This interpreter will invalidate all higher-order effects of any
-- interpreter run after it; i.e. 'Polysemy.Reader.local' and
-- 'Polysemy.Writer.censor' will be no-ops, 'Polysemy.Error.catch' will fail
-- to catch exceptions, and 'Polysemy.Writer.listen' will always return 'mempty'.
--
-- __You should therefore use 'runContWithCUnsafe' /after/ running all interpreters
-- for your higher-order effects.__
runContWithCUnsafe :: (a -> Sem r s) -> Sem (Cont (Ref (Sem r) s) ': r) a -> Sem r s
runContWithCUnsafe :: (a -> Sem r s) -> Sem (Cont (Ref (Sem r) s) : r) a -> Sem r s
runContWithCUnsafe a -> Sem r s
c (Sem forall (m :: * -> *).
Monad m =>
(forall x.
 Union (Cont (Ref (Sem r) s) : r) (Sem (Cont (Ref (Sem r) s) : r)) x
 -> m x)
-> m a
m) = (ContT s (Sem r) a -> (a -> Sem r s) -> Sem r s
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
`runContT` a -> Sem r s
c) (ContT s (Sem r) a -> Sem r s) -> ContT s (Sem r) a -> Sem r s
forall a b. (a -> b) -> a -> b
$ (forall x.
 Union (Cont (Ref (Sem r) s) : r) (Sem (Cont (Ref (Sem r) s) : r)) x
 -> ContT s (Sem r) x)
-> ContT s (Sem r) a
forall (m :: * -> *).
Monad m =>
(forall x.
 Union (Cont (Ref (Sem r) s) : r) (Sem (Cont (Ref (Sem r) s) : r)) x
 -> m x)
-> m a
m ((forall x.
  Union (Cont (Ref (Sem r) s) : r) (Sem (Cont (Ref (Sem r) s) : r)) x
  -> ContT s (Sem r) x)
 -> ContT s (Sem r) a)
-> (forall x.
    Union (Cont (Ref (Sem r) s) : r) (Sem (Cont (Ref (Sem r) s) : r)) x
    -> ContT s (Sem r) x)
-> ContT s (Sem r) a
forall a b. (a -> b) -> a -> b
$ \Union (Cont (Ref (Sem r) s) : r) (Sem (Cont (Ref (Sem r) s) : r)) x
u -> case Union (Cont (Ref (Sem r) s) : r) (Sem (Cont (Ref (Sem r) s) : r)) x
-> Either
     (Union r (Sem (Cont (Ref (Sem r) s) : r)) x)
     (Weaving (Cont (Ref (Sem r) s)) (Sem (Cont (Ref (Sem r) s) : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (Cont (Ref (Sem r) s) : r) (Sem (Cont (Ref (Sem r) s) : r)) x
u of
  Right Weaving (Cont (Ref (Sem r) s)) (Sem (Cont (Ref (Sem r) s) : r)) x
weaving -> (forall x.
 (x -> Sem r s) -> Sem (Cont (Ref (Sem r) s) : r) x -> Sem r s)
-> Weaving
     (Cont (Ref (Sem r) s)) (Sem (Cont (Ref (Sem r) s) : r)) x
-> ContT s (Sem r) x
forall (m :: * -> *) s (r :: [(* -> *) -> * -> *]) a.
Monad m =>
(forall x. (x -> m s) -> Sem r x -> m s)
-> Weaving (Cont (Ref m s)) (Sem r) a -> ContT s m a
runContWeaving forall x.
(x -> Sem r s) -> Sem (Cont (Ref (Sem r) s) : r) x -> Sem r s
forall a (r :: [(* -> *) -> * -> *]) s.
(a -> Sem r s) -> Sem (Cont (Ref (Sem r) s) : r) a -> Sem r s
runContWithCUnsafe Weaving (Cont (Ref (Sem r) s)) (Sem (Cont (Ref (Sem r) s) : r)) x
weaving
  Left Union r (Sem (Cont (Ref (Sem r) s) : r)) x
g -> ((x -> Sem r s) -> Sem r s) -> ContT s (Sem r) x
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((x -> Sem r s) -> Sem r s) -> ContT s (Sem r) x)
-> ((x -> Sem r s) -> Sem r s) -> ContT s (Sem r) x
forall a b. (a -> b) -> a -> b
$ \x -> Sem r s
c' -> Union r (Sem (Cont (Ref (Sem r) s) : r)) x
-> Sem r (Sem (Cont (Ref (Sem r) s) : r) x)
forall (r :: [(* -> *) -> * -> *]) (r' :: [(* -> *) -> * -> *]) a.
Union r (Sem r') a -> Sem r (Sem r' a)
embedSem Union r (Sem (Cont (Ref (Sem r) s) : r)) x
g Sem r (Sem (Cont (Ref (Sem r) s) : r) x)
-> (Sem (Cont (Ref (Sem r) s) : r) x -> Sem r s) -> Sem r s
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (x -> Sem r s) -> Sem (Cont (Ref (Sem r) s) : r) x -> Sem r s
forall a (r :: [(* -> *) -> * -> *]) s.
(a -> Sem r s) -> Sem (Cont (Ref (Sem r) s) : r) a -> Sem r s
runContWithCUnsafe x -> Sem r s
c'
{-# INLINE runContWithCUnsafe #-}

runContWeaving :: Monad m
               => (forall x. (x -> m s) -> Sem r x -> m s)
               -> Weaving (Cont (Ref m s)) (Sem r) a
               -> ContT s m a
runContWeaving :: (forall x. (x -> m s) -> Sem r x -> m s)
-> Weaving (Cont (Ref m s)) (Sem r) a -> ContT s m a
runContWeaving forall x. (x -> m s) -> Sem r x -> m s
runW (Weaving Cont (Ref m s) (Sem rInitial) a
e f ()
s forall x. f (Sem rInitial x) -> Sem r (f x)
wv f a -> a
ex forall x. f x -> Maybe x
_) =
    ((a -> m s) -> m s) -> ContT s m a
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((a -> m s) -> m s) -> ContT s m a)
-> ((a -> m s) -> m s) -> ContT s m a
forall a b. (a -> b) -> a -> b
$ \a -> m s
c ->
      case Cont (Ref m s) (Sem rInitial) a
e of
        Jump Ref m s a
ref a
a    -> Ref m s a -> a -> m s
forall k (m :: k -> *) (s :: k) a. Ref m s a -> a -> m s
runRef Ref m s a
ref a
a
        Subst Ref m s a -> Sem rInitial a
main a -> Sem rInitial a
cb ->
          let
            callback :: a -> m s
callback a
a = (f a -> m s) -> Sem r (f a) -> m s
forall x. (x -> m s) -> Sem r x -> m s
runW (a -> m s
c (a -> m s) -> (f a -> a) -> f a -> m s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> a
ex) (f (Sem rInitial a) -> Sem r (f a)
forall x. f (Sem rInitial x) -> Sem r (f x)
wv (a -> Sem rInitial a
cb a
a Sem rInitial a -> f () -> f (Sem rInitial a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
          in
            (f a -> m s) -> Sem r (f a) -> m s
forall x. (x -> m s) -> Sem r x -> m s
runW (a -> m s
c (a -> m s) -> (f a -> a) -> f a -> m s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> a
ex) (f (Sem rInitial a) -> Sem r (f a)
forall x. f (Sem rInitial x) -> Sem r (f x)
wv (Ref m s a -> Sem rInitial a
main ((a -> m s) -> Ref m s a
forall k (m :: k -> *) (s :: k) a. (a -> m s) -> Ref m s a
Ref a -> m s
callback) Sem rInitial a -> f () -> f (Sem rInitial a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s))
{-# INLINE runContWeaving #-}

inspectSem :: Sem r a -> Maybe a
inspectSem :: Sem r a -> Maybe a
inspectSem (Sem forall (m :: * -> *).
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> m a
m) = (forall x. Union r (Sem r) x -> Maybe x) -> Maybe a
forall (m :: * -> *).
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> m a
m (\Union r (Sem r) x
_ -> Maybe x
forall a. Maybe a
Nothing)
{-# INLINE inspectSem #-}

embedSem :: Union r (Sem r') a -> Sem r (Sem r' a)
embedSem :: Union r (Sem r') a -> Sem r (Sem r' a)
embedSem = Union r (Sem r) (Sem r' a) -> Sem r (Sem r' a)
forall (r :: [(* -> *) -> * -> *]) a. Union r (Sem r) a -> Sem r a
liftSem (Union r (Sem r) (Sem r' a) -> Sem r (Sem r' a))
-> (Union r (Sem r') a -> Union r (Sem r) (Sem r' a))
-> Union r (Sem r') a
-> Sem r (Sem r' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r' ()
-> (forall x. Sem r' (Sem r' x) -> Sem r (Sem r' x))
-> (forall x. Sem r' x -> Maybe x)
-> Union r (Sem r') a
-> Union r (Sem r) (Sem r' a)
forall (s :: * -> *) (n :: * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]) a.
(Functor s, Functor n) =>
s ()
-> (forall x. s (m x) -> n (s x))
-> (forall x. s x -> Maybe x)
-> Union r m a
-> Union r n (s a)
weave (() -> Sem r' ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Sem r' x -> Sem r (Sem r' x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Sem r' x -> Sem r (Sem r' x))
-> (Sem r' (Sem r' x) -> Sem r' x)
-> Sem r' (Sem r' x)
-> Sem r (Sem r' x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem r' (Sem r' x) -> Sem r' x
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join) forall (r :: [(* -> *) -> * -> *]) a. Sem r a -> Maybe a
forall x. Sem r' x -> Maybe x
inspectSem
{-# INLINE embedSem #-}

newtype Ref m s a = Ref { Ref m s a -> a -> m s
runRef :: a -> m s }

instance Contravariant (Ref m s) where
  contramap :: (a -> b) -> Ref m s b -> Ref m s a
contramap a -> b
f Ref m s b
ref = (a -> m s) -> Ref m s a
forall k (m :: k -> *) (s :: k) a. (a -> m s) -> Ref m s a
Ref (Ref m s b -> b -> m s
forall k (m :: k -> *) (s :: k) a. Ref m s a -> a -> m s
runRef Ref m s b
ref (b -> m s) -> (a -> b) -> a -> m s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

newtype ExitRef m a = ExitRef { ExitRef m a -> forall (b :: k). a -> m b
enterExit :: forall b. a -> m b }

instance Contravariant (ExitRef m) where
  contramap :: (a -> b) -> ExitRef m b -> ExitRef m a
contramap a -> b
f ExitRef m b
ref = (forall (b :: k). a -> m b) -> ExitRef m a
forall k (m :: k -> *) a.
(forall (b :: k). a -> m b) -> ExitRef m a
ExitRef ((forall (b :: k). a -> m b) -> ExitRef m a)
-> (forall (b :: k). a -> m b) -> ExitRef m a
forall a b. (a -> b) -> a -> b
$ \a
a -> ExitRef m b -> b -> m b
forall k (m :: k -> *) a. ExitRef m a -> forall (b :: k). a -> m b
enterExit ExitRef m b
ref (a -> b
f a
a)

data ViaFreshRef uniq a = ViaFreshRef { ViaFreshRef uniq a -> a -> (uniq, Any)
getBacktrackException :: a -> (uniq, Any) }

instance Contravariant (ViaFreshRef uniq) where
  contramap :: (a -> b) -> ViaFreshRef uniq b -> ViaFreshRef uniq a
contramap a -> b
f ViaFreshRef uniq b
ref = (a -> (uniq, Any)) -> ViaFreshRef uniq a
forall uniq a. (a -> (uniq, Any)) -> ViaFreshRef uniq a
ViaFreshRef ((a -> (uniq, Any)) -> ViaFreshRef uniq a)
-> (a -> (uniq, Any)) -> ViaFreshRef uniq a
forall a b. (a -> b) -> a -> b
$ \a
a -> ViaFreshRef uniq b -> b -> (uniq, Any)
forall uniq a. ViaFreshRef uniq a -> a -> (uniq, Any)
getBacktrackException ViaFreshRef uniq b
ref (a -> b
f a
a)

{-
  KingoftheHomeless: OK, so let's discuss how this works.
  The idea here is to instead of providing a monadic computation
  to the call of 'callCC' that simply short-circuits everything like
  'ContT' does, we fake that behaviour by instead providing an
  exception to 'callCC', and then try to 'catch' that exception
  on the continuation. If the exception is caught, then we run the
  continuation again. This way, we can get abortive continuations
  without having to scope over a result type variable, avoiding
  the problem that 'runContUnsafe' has, and making it possible
  to weave other effects through without breaking everything.

  Even with that solution, weaving effects through have more problems
  of their own; namely, if we simply lower a
  'forall s. ContT s (Sem r) a' to 'Sem r a', then we effectively
  delimit all higher-order computations. This is bad, because
  if a reified continuation produced within
  the higher-order computation escapes from it,
  then nothing can catch the underlying backtrack exception
  once it is thrown.

  The solution to this is anothor kludge: when weaving other effects through,
  we instead use 'runContViaFreshInCWeave'; this makes use 'ContFreshState'
  as its functorial state, which stores /handlers/ for backtrack exceptions.
  'runContViaFreshInCWeave', in addition to 'catch'ing exceptions on the continuation
  it is given, /also/ returns the handler it uses for the 'catch'.
  This handler is then used by 'runContViaFresh' to catch exceptions on the
  continuation /it/ gets, but can't provide to the higher-order computation.

  I'm astonished that this even remotely works, but it does have some rather
  weird behaviour I haven't completely figured out yet.

  I'm reasonably happy with how 'runContViaFreshInC' looks;
  I'm a lot less happy with 'runContViaFreshInCWeave', I just kinda threw
  it haphazardly. I figure most weirdness stem from issues in
  'runContViaFreshInCWeave', so I need to think it through some more.
-}
-- | Intermediary monadic interpretation used for running 'runContViaFresh'.
-- See source for a discussion on how this works.
runContViaFreshInC :: forall uniq s r a
                    . (Member (Fresh uniq) r, Eq uniq)
                   => Sem (Cont (ViaFreshRef uniq) ': r) a
                   -> ContT s (Sem (Error (uniq, Any) ': r)) a
runContViaFreshInC :: Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT s (Sem (Error (uniq, Any) : r)) a
runContViaFreshInC = (forall x.
 Union
   (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
 -> ContT s (Sem (Error (uniq, Any) : r)) x)
-> Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT s (Sem (Error (uniq, Any) : r)) a
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem ((forall x.
  Union
    (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
  -> ContT s (Sem (Error (uniq, Any) : r)) x)
 -> Sem (Cont (ViaFreshRef uniq) : r) a
 -> ContT s (Sem (Error (uniq, Any) : r)) a)
-> (forall x.
    Union
      (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
    -> ContT s (Sem (Error (uniq, Any) : r)) x)
-> Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT s (Sem (Error (uniq, Any) : r)) a
forall a b. (a -> b) -> a -> b
$ \Union
  (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
u -> ((x -> Sem (Error (uniq, Any) : r) s)
 -> Sem (Error (uniq, Any) : r) s)
-> ContT s (Sem (Error (uniq, Any) : r)) x
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((x -> Sem (Error (uniq, Any) : r) s)
  -> Sem (Error (uniq, Any) : r) s)
 -> ContT s (Sem (Error (uniq, Any) : r)) x)
-> ((x -> Sem (Error (uniq, Any) : r) s)
    -> Sem (Error (uniq, Any) : r) s)
-> ContT s (Sem (Error (uniq, Any) : r)) x
forall a b. (a -> b) -> a -> b
$ \x -> Sem (Error (uniq, Any) : r) s
c ->
  case Union
  (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
-> Either
     (Union r (Sem (Cont (ViaFreshRef uniq) : r)) x)
     (Weaving
        (Cont (ViaFreshRef uniq)) (Sem (Cont (ViaFreshRef uniq) : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union
  (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
u of
    Right (Weaving Cont (ViaFreshRef uniq) (Sem rInitial) a
e f ()
s forall x.
f (Sem rInitial x) -> Sem (Cont (ViaFreshRef uniq) : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
_) ->
      case Cont (ViaFreshRef uniq) (Sem rInitial) a
e of
        Subst main cn -> do
          uniq
ref <- Sem (Error (uniq, Any) : r) uniq
forall uniq (r :: [(* -> *) -> * -> *]).
Member (Fresh uniq) r =>
Sem r uniq
fresh
          let
            main' :: ViaFreshRef uniq a -> ContT s (Sem (Error (uniq, Any) : r)) (f a)
main' = Sem (Cont (ViaFreshRef uniq) : r) (f a)
-> ContT s (Sem (Error (uniq, Any) : r)) (f a)
forall uniq s (r :: [(* -> *) -> * -> *]) a.
(Member (Fresh uniq) r, Eq uniq) =>
Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT s (Sem (Error (uniq, Any) : r)) a
runContViaFreshInC (Sem (Cont (ViaFreshRef uniq) : r) (f a)
 -> ContT s (Sem (Error (uniq, Any) : r)) (f a))
-> (ViaFreshRef uniq a -> Sem (Cont (ViaFreshRef uniq) : r) (f a))
-> ViaFreshRef uniq a
-> ContT s (Sem (Error (uniq, Any) : r)) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial a) -> Sem (Cont (ViaFreshRef uniq) : r) (f a)
forall x.
f (Sem rInitial x) -> Sem (Cont (ViaFreshRef uniq) : r) (f x)
wv (f (Sem rInitial a) -> Sem (Cont (ViaFreshRef uniq) : r) (f a))
-> (ViaFreshRef uniq a -> f (Sem rInitial a))
-> ViaFreshRef uniq a
-> Sem (Cont (ViaFreshRef uniq) : r) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ViaFreshRef uniq a -> Sem rInitial a)
-> f (ViaFreshRef uniq a) -> f (Sem rInitial a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ViaFreshRef uniq a -> Sem rInitial a
main (f (ViaFreshRef uniq a) -> f (Sem rInitial a))
-> (ViaFreshRef uniq a -> f (ViaFreshRef uniq a))
-> ViaFreshRef uniq a
-> f (Sem rInitial a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ViaFreshRef uniq a -> f () -> f (ViaFreshRef uniq a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
            cn' :: a -> ContT s (Sem (Error (uniq, Any) : r)) (f a)
cn'   = Sem (Cont (ViaFreshRef uniq) : r) (f a)
-> ContT s (Sem (Error (uniq, Any) : r)) (f a)
forall uniq s (r :: [(* -> *) -> * -> *]) a.
(Member (Fresh uniq) r, Eq uniq) =>
Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT s (Sem (Error (uniq, Any) : r)) a
runContViaFreshInC (Sem (Cont (ViaFreshRef uniq) : r) (f a)
 -> ContT s (Sem (Error (uniq, Any) : r)) (f a))
-> (a -> Sem (Cont (ViaFreshRef uniq) : r) (f a))
-> a
-> ContT s (Sem (Error (uniq, Any) : r)) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial a) -> Sem (Cont (ViaFreshRef uniq) : r) (f a)
forall x.
f (Sem rInitial x) -> Sem (Cont (ViaFreshRef uniq) : r) (f x)
wv (f (Sem rInitial a) -> Sem (Cont (ViaFreshRef uniq) : r) (f a))
-> (a -> f (Sem rInitial a))
-> a
-> Sem (Cont (ViaFreshRef uniq) : r) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Sem rInitial a) -> f a -> f (Sem rInitial a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Sem rInitial a
cn (f a -> f (Sem rInitial a))
-> (a -> f a) -> a -> f (Sem rInitial a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
            loop :: ContT s (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) s
loop ContT s (Sem (Error (uniq, Any) : r)) (f a)
act =
              ContT s (Sem (Error (uniq, Any) : r)) x
-> (x -> Sem (Error (uniq, Any) : r) s)
-> Sem (Error (uniq, Any) : r) s
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT (f a -> x
ex (f a -> x)
-> ContT s (Sem (Error (uniq, Any) : r)) (f a)
-> ContT s (Sem (Error (uniq, Any) : r)) x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContT s (Sem (Error (uniq, Any) : r)) (f a)
act) x -> Sem (Error (uniq, Any) : r) s
c Sem (Error (uniq, Any) : r) s
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
-> Sem (Error (uniq, Any) : r) s
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
`catch` \ x :: (uniq, Any)
x@(uniq
ref', Any
a') -> do
                if uniq
ref uniq -> uniq -> Bool
forall a. Eq a => a -> a -> Bool
== uniq
ref' then
                  ContT s (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) s
loop (a -> ContT s (Sem (Error (uniq, Any) : r)) (f a)
cn' (a -> ContT s (Sem (Error (uniq, Any) : r)) (f a))
-> a -> ContT s (Sem (Error (uniq, Any) : r)) (f a)
forall a b. (a -> b) -> a -> b
$ Any -> a
forall a b. a -> b
unsafeCoerce Any
a')
                else
                  (uniq, Any) -> Sem (Error (uniq, Any) : r) s
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem r a
throw @(uniq, Any) (uniq, Any)
x
          ContT s (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) s
loop (ContT s (Sem (Error (uniq, Any) : r)) (f a)
 -> Sem (Error (uniq, Any) : r) s)
-> ContT s (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) s
forall a b. (a -> b) -> a -> b
$ ViaFreshRef uniq a -> ContT s (Sem (Error (uniq, Any) : r)) (f a)
main' (ViaFreshRef uniq a -> ContT s (Sem (Error (uniq, Any) : r)) (f a))
-> ViaFreshRef uniq a
-> ContT s (Sem (Error (uniq, Any) : r)) (f a)
forall a b. (a -> b) -> a -> b
$ (a -> (uniq, Any)) -> ViaFreshRef uniq a
forall uniq a. (a -> (uniq, Any)) -> ViaFreshRef uniq a
ViaFreshRef (\a
a -> (uniq
ref, a -> Any
forall a b. a -> b
unsafeCoerce a
a))
        Jump ref a -> (uniq, Any) -> Sem (Error (uniq, Any) : r) s
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem r a
throw (ViaFreshRef uniq a -> a -> (uniq, Any)
forall uniq a. ViaFreshRef uniq a -> a -> (uniq, Any)
getBacktrackException ViaFreshRef uniq a
ref a
a)
    Left Union r (Sem (Cont (ViaFreshRef uniq) : r)) x
g -> do
      ResAndHandler x
a (uniq, Any) -> Sem (Error (uniq, Any) : r) x
rc <- Union
  (Error (uniq, Any) : r)
  (Sem (Error (uniq, Any) : r))
  (ContFreshState uniq r x)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall (r :: [(* -> *) -> * -> *]) a. Union r (Sem r) a -> Sem r a
liftSem (Union
   (Error (uniq, Any) : r)
   (Sem (Error (uniq, Any) : r))
   (ContFreshState uniq r x)
 -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x))
-> Union
     (Error (uniq, Any) : r)
     (Sem (Error (uniq, Any) : r))
     (ContFreshState uniq r x)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall a b. (a -> b) -> a -> b
$
        ContFreshState uniq r ()
-> (forall x.
    ContFreshState uniq r (Sem (Cont (ViaFreshRef uniq) : r) x)
    -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x))
-> (forall x. ContFreshState uniq r x -> Maybe x)
-> Union
     (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
-> Union
     (Error (uniq, Any) : r)
     (Sem (Error (uniq, Any) : r))
     (ContFreshState uniq r x)
forall (s :: * -> *) (n :: * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]) a.
(Functor s, Functor n) =>
s ()
-> (forall x. s (m x) -> n (s x))
-> (forall x. s x -> Maybe x)
-> Union r m a
-> Union r n (s a)
weave
          (()
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) ())
-> ContFreshState uniq r ()
forall uniq (r :: [(* -> *) -> * -> *]) a.
a
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) a)
-> ContFreshState uniq r a
ResAndHandler @uniq @r () (uniq, Any) -> Sem (Error (uniq, Any) : r) ()
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem r a
throw)
          -- TODO(KingoftheHomeless): is this the distributive law we want?
          (\(ResAndHandler Sem (Cont (ViaFreshRef uniq) : r) x
a (uniq, Any)
-> Sem
     (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r) x)
rc) ->
            ContT (ContFreshState uniq r x) (Sem (Error (uniq, Any) : r)) x
-> (x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x))
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT
              (Sem (Cont (ViaFreshRef uniq) : r) x
-> ContT (ContFreshState uniq r x) (Sem (Error (uniq, Any) : r)) x
forall uniq s (r :: [(* -> *) -> * -> *]) a.
(Member (Fresh uniq) r, Eq uniq) =>
Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) a
runContViaFreshInCWeave Sem (Cont (ViaFreshRef uniq) : r) x
a)
              (\x
x -> ContFreshState uniq r x
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContFreshState uniq r x
 -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x))
-> ContFreshState uniq r x
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall a b. (a -> b) -> a -> b
$
                x
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) x)
-> ContFreshState uniq r x
forall uniq (r :: [(* -> *) -> * -> *]) a.
a
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) a)
-> ContFreshState uniq r a
ResAndHandler
                  x
x
                  ((uniq, Any)
-> Sem
     (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r) x)
rc ((uniq, Any)
 -> Sem
      (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r) x))
-> (Sem (Cont (ViaFreshRef uniq) : r) x
    -> Sem (Error (uniq, Any) : r) x)
-> (uniq, Any)
-> Sem (Error (uniq, Any) : r) x
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ContT x (Sem (Error (uniq, Any) : r)) x
-> (x -> Sem (Error (uniq, Any) : r) x)
-> Sem (Error (uniq, Any) : r) x
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
`runContT` x -> Sem (Error (uniq, Any) : r) x
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (ContT x (Sem (Error (uniq, Any) : r)) x
 -> Sem (Error (uniq, Any) : r) x)
-> (Sem (Cont (ViaFreshRef uniq) : r) x
    -> ContT x (Sem (Error (uniq, Any) : r)) x)
-> Sem (Cont (ViaFreshRef uniq) : r) x
-> Sem (Error (uniq, Any) : r) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Cont (ViaFreshRef uniq) : r) x
-> ContT x (Sem (Error (uniq, Any) : r)) x
forall uniq s (r :: [(* -> *) -> * -> *]) a.
(Member (Fresh uniq) r, Eq uniq) =>
Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT s (Sem (Error (uniq, Any) : r)) a
runContViaFreshInC)
              )
          )
          (x -> Maybe x
forall a. a -> Maybe a
Just (x -> Maybe x)
-> (ContFreshState uniq r x -> x)
-> ContFreshState uniq r x
-> Maybe x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContFreshState uniq r x -> x
forall uniq (r :: [(* -> *) -> * -> *]) a.
ContFreshState uniq r a -> a
getResult)
          (Union r (Sem (Cont (ViaFreshRef uniq) : r)) x
-> Union
     (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Union r m a -> Union (e : r) m a
weaken Union r (Sem (Cont (ViaFreshRef uniq) : r)) x
g)
      let loop :: x -> Sem (Error (uniq, Any) : r) s
loop x
x = x -> Sem (Error (uniq, Any) : r) s
c x
x Sem (Error (uniq, Any) : r) s
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
-> Sem (Error (uniq, Any) : r) s
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
`catch` ((uniq, Any) -> Sem (Error (uniq, Any) : r) x
rc ((uniq, Any) -> Sem (Error (uniq, Any) : r) x)
-> (x -> Sem (Error (uniq, Any) : r) s)
-> (uniq, Any)
-> Sem (Error (uniq, Any) : r) s
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> x -> Sem (Error (uniq, Any) : r) s
loop)
      x -> Sem (Error (uniq, Any) : r) s
loop x
a

-- | A variant of 'runContViaFreshInC' which it uses when weaving other effects through.
runContViaFreshInCWeave :: forall uniq s r a
                         . (Member (Fresh uniq) r, Eq uniq)
                        => Sem (Cont (ViaFreshRef uniq) ': r) a
                        -> ContT (ContFreshState uniq r s)
                            (Sem (Error (uniq, Any) ': r))
                            a
runContViaFreshInCWeave :: Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) a
runContViaFreshInCWeave = (forall x.
 Union
   (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
 -> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) x)
-> Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) a
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem ((forall x.
  Union
    (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
  -> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) x)
 -> Sem (Cont (ViaFreshRef uniq) : r) a
 -> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) a)
-> (forall x.
    Union
      (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
    -> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) x)
-> Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) a
forall a b. (a -> b) -> a -> b
$ \Union
  (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
u -> ((x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
 -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) x
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
  -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
 -> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) x)
-> ((x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
    -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) x
forall a b. (a -> b) -> a -> b
$ \x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
c ->
  case Union
  (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
-> Either
     (Union r (Sem (Cont (ViaFreshRef uniq) : r)) x)
     (Weaving
        (Cont (ViaFreshRef uniq)) (Sem (Cont (ViaFreshRef uniq) : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union
  (Cont (ViaFreshRef uniq) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
u of
    Right (Weaving Cont (ViaFreshRef uniq) (Sem rInitial) a
e f ()
s forall x.
f (Sem rInitial x) -> Sem (Cont (ViaFreshRef uniq) : r) (f x)
wv f a -> x
ex forall x. f x -> Maybe x
_) ->
      case Cont (ViaFreshRef uniq) (Sem rInitial) a
e of
        Subst main cn -> do
          uniq
ref <- Sem (Error (uniq, Any) : r) uniq
forall uniq (r :: [(* -> *) -> * -> *]).
Member (Fresh uniq) r =>
Sem r uniq
fresh
          let
            -- TODO(KingoftheHomeless): runContViaFreshInC?
            main' :: ViaFreshRef uniq a
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
main' = Sem (Cont (ViaFreshRef uniq) : r) (f a)
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
forall uniq s (r :: [(* -> *) -> * -> *]) a.
(Member (Fresh uniq) r, Eq uniq) =>
Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) a
runContViaFreshInCWeave (Sem (Cont (ViaFreshRef uniq) : r) (f a)
 -> ContT
      (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a))
-> (ViaFreshRef uniq a -> Sem (Cont (ViaFreshRef uniq) : r) (f a))
-> ViaFreshRef uniq a
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial a) -> Sem (Cont (ViaFreshRef uniq) : r) (f a)
forall x.
f (Sem rInitial x) -> Sem (Cont (ViaFreshRef uniq) : r) (f x)
wv (f (Sem rInitial a) -> Sem (Cont (ViaFreshRef uniq) : r) (f a))
-> (ViaFreshRef uniq a -> f (Sem rInitial a))
-> ViaFreshRef uniq a
-> Sem (Cont (ViaFreshRef uniq) : r) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ViaFreshRef uniq a -> Sem rInitial a)
-> f (ViaFreshRef uniq a) -> f (Sem rInitial a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ViaFreshRef uniq a -> Sem rInitial a
main (f (ViaFreshRef uniq a) -> f (Sem rInitial a))
-> (ViaFreshRef uniq a -> f (ViaFreshRef uniq a))
-> ViaFreshRef uniq a
-> f (Sem rInitial a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ViaFreshRef uniq a -> f () -> f (ViaFreshRef uniq a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
            cn' :: a
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
cn'   = Sem (Cont (ViaFreshRef uniq) : r) (f a)
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
forall uniq s (r :: [(* -> *) -> * -> *]) a.
(Member (Fresh uniq) r, Eq uniq) =>
Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) a
runContViaFreshInCWeave (Sem (Cont (ViaFreshRef uniq) : r) (f a)
 -> ContT
      (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a))
-> (a -> Sem (Cont (ViaFreshRef uniq) : r) (f a))
-> a
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Sem rInitial a) -> Sem (Cont (ViaFreshRef uniq) : r) (f a)
forall x.
f (Sem rInitial x) -> Sem (Cont (ViaFreshRef uniq) : r) (f x)
wv (f (Sem rInitial a) -> Sem (Cont (ViaFreshRef uniq) : r) (f a))
-> (a -> f (Sem rInitial a))
-> a
-> Sem (Cont (ViaFreshRef uniq) : r) (f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Sem rInitial a) -> f a -> f (Sem rInitial a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Sem rInitial a
cn (f a -> f (Sem rInitial a))
-> (a -> f a) -> a -> f (Sem rInitial a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f () -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
            loop :: ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
loop ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
act =
              ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) x
-> (x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT (f a -> x
ex (f a -> x)
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) x
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
act) x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
c Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
-> ((uniq, Any)
    -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
`catch` \ x :: (uniq, Any)
x@(uniq
ref', Any
a') -> do
                if uniq
ref uniq -> uniq -> Bool
forall a. Eq a => a -> a -> Bool
== uniq
ref' then
                  ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
loop (a
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
cn' (a
 -> ContT
      (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a))
-> a
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
forall a b. (a -> b) -> a -> b
$ Any -> a
forall a b. a -> b
unsafeCoerce Any
a')
                else
                  (uniq, Any)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem r a
throw @(uniq, Any) (uniq, Any)
x
          ResAndHandler s
res (uniq, Any) -> Sem (Error (uniq, Any) : r) s
h <-
            ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
loop (ContT
   (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
 -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall a b. (a -> b) -> a -> b
$ ViaFreshRef uniq a
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
main' (ViaFreshRef uniq a
 -> ContT
      (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a))
-> ViaFreshRef uniq a
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
forall a b. (a -> b) -> a -> b
$ (a -> (uniq, Any)) -> ViaFreshRef uniq a
forall uniq a. (a -> (uniq, Any)) -> ViaFreshRef uniq a
ViaFreshRef (\a
a -> (uniq
ref, a -> Any
forall a b. a -> b
unsafeCoerce a
a))
          ContFreshState uniq r s
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall (m :: * -> *) a. Monad m => a -> m a
return (ContFreshState uniq r s
 -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> ContFreshState uniq r s
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall a b. (a -> b) -> a -> b
$ s
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
-> ContFreshState uniq r s
forall uniq (r :: [(* -> *) -> * -> *]) a.
a
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) a)
-> ContFreshState uniq r a
ResAndHandler s
res
              -- TODO(KingoftheHomeless): This handler is dubious.
            (((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
 -> ContFreshState uniq r s)
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
-> ContFreshState uniq r s
forall a b. (a -> b) -> a -> b
$ \(uniq, Any)
x -> (ContFreshState uniq r s -> s)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
-> Sem (Error (uniq, Any) : r) s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ContFreshState uniq r s -> s
forall uniq (r :: [(* -> *) -> * -> *]) a.
ContFreshState uniq r a -> a
getResult (Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
 -> Sem (Error (uniq, Any) : r) s)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
-> Sem (Error (uniq, Any) : r) s
forall a b. (a -> b) -> a -> b
$ ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
loop (ContT
   (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
 -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall a b. (a -> b) -> a -> b
$ ((f a -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
 -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
forall k (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((f a -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
  -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
 -> ContT
      (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a))
-> ((f a -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
    -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> ContT
     (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) (f a)
forall a b. (a -> b) -> a -> b
$ \f a -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
_ -> (s -> ContFreshState uniq r s)
-> Sem (Error (uniq, Any) : r) s
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
-> ContFreshState uniq r s
forall uniq (r :: [(* -> *) -> * -> *]) a.
a
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) a)
-> ContFreshState uniq r a
`ResAndHandler` (uniq, Any) -> Sem (Error (uniq, Any) : r) s
h) ((uniq, Any) -> Sem (Error (uniq, Any) : r) s
h (uniq, Any)
x)
        Jump ref a -> (uniq, Any)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem r a
throw (ViaFreshRef uniq a -> a -> (uniq, Any)
forall uniq a. ViaFreshRef uniq a -> a -> (uniq, Any)
getBacktrackException ViaFreshRef uniq a
ref a
a)
    Left Union r (Sem (Cont (ViaFreshRef uniq) : r)) x
g -> do
      ResAndHandler x
a (uniq, Any) -> Sem (Error (uniq, Any) : r) x
h <- Union
  (Error (uniq, Any) : r)
  (Sem (Error (uniq, Any) : r))
  (ContFreshState uniq r x)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall (r :: [(* -> *) -> * -> *]) a. Union r (Sem r) a -> Sem r a
liftSem (Union
   (Error (uniq, Any) : r)
   (Sem (Error (uniq, Any) : r))
   (ContFreshState uniq r x)
 -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x))
-> Union
     (Error (uniq, Any) : r)
     (Sem (Error (uniq, Any) : r))
     (ContFreshState uniq r x)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall a b. (a -> b) -> a -> b
$
        ContFreshState uniq r ()
-> (forall x.
    ContFreshState uniq r (Sem (Cont (ViaFreshRef uniq) : r) x)
    -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x))
-> (forall x. ContFreshState uniq r x -> Maybe x)
-> Union
     (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
-> Union
     (Error (uniq, Any) : r)
     (Sem (Error (uniq, Any) : r))
     (ContFreshState uniq r x)
forall (s :: * -> *) (n :: * -> *) (m :: * -> *)
       (r :: [(* -> *) -> * -> *]) a.
(Functor s, Functor n) =>
s ()
-> (forall x. s (m x) -> n (s x))
-> (forall x. s x -> Maybe x)
-> Union r m a
-> Union r n (s a)
weave
          (()
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) ())
-> ContFreshState uniq r ()
forall uniq (r :: [(* -> *) -> * -> *]) a.
a
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) a)
-> ContFreshState uniq r a
ResAndHandler @uniq @r () (uniq, Any) -> Sem (Error (uniq, Any) : r) ()
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
e -> Sem r a
throw)
          (\(ResAndHandler Sem (Cont (ViaFreshRef uniq) : r) x
a (uniq, Any)
-> Sem
     (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r) x)
rc) ->
            ContT (ContFreshState uniq r x) (Sem (Error (uniq, Any) : r)) x
-> (x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x))
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
runContT
              (Sem (Cont (ViaFreshRef uniq) : r) x
-> ContT (ContFreshState uniq r x) (Sem (Error (uniq, Any) : r)) x
forall uniq s (r :: [(* -> *) -> * -> *]) a.
(Member (Fresh uniq) r, Eq uniq) =>
Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT (ContFreshState uniq r s) (Sem (Error (uniq, Any) : r)) a
runContViaFreshInCWeave Sem (Cont (ViaFreshRef uniq) : r) x
a)
              (\x
x -> ContFreshState uniq r x
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ContFreshState uniq r x
 -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x))
-> ContFreshState uniq r x
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r x)
forall a b. (a -> b) -> a -> b
$
                x
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) x)
-> ContFreshState uniq r x
forall uniq (r :: [(* -> *) -> * -> *]) a.
a
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) a)
-> ContFreshState uniq r a
ResAndHandler
                  x
x
                  ((uniq, Any)
-> Sem
     (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r) x)
rc ((uniq, Any)
 -> Sem
      (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r) x))
-> (Sem (Cont (ViaFreshRef uniq) : r) x
    -> Sem (Error (uniq, Any) : r) x)
-> (uniq, Any)
-> Sem (Error (uniq, Any) : r) x
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ContT x (Sem (Error (uniq, Any) : r)) x
-> (x -> Sem (Error (uniq, Any) : r) x)
-> Sem (Error (uniq, Any) : r) x
forall k (r :: k) (m :: k -> *) a. ContT r m a -> (a -> m r) -> m r
`runContT` x -> Sem (Error (uniq, Any) : r) x
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (ContT x (Sem (Error (uniq, Any) : r)) x
 -> Sem (Error (uniq, Any) : r) x)
-> (Sem (Cont (ViaFreshRef uniq) : r) x
    -> ContT x (Sem (Error (uniq, Any) : r)) x)
-> Sem (Cont (ViaFreshRef uniq) : r) x
-> Sem (Error (uniq, Any) : r) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (Cont (ViaFreshRef uniq) : r) x
-> ContT x (Sem (Error (uniq, Any) : r)) x
forall uniq s (r :: [(* -> *) -> * -> *]) a.
(Member (Fresh uniq) r, Eq uniq) =>
Sem (Cont (ViaFreshRef uniq) : r) a
-> ContT s (Sem (Error (uniq, Any) : r)) a
runContViaFreshInC)
              )
          )
          (x -> Maybe x
forall a. a -> Maybe a
Just (x -> Maybe x)
-> (ContFreshState uniq r x -> x)
-> ContFreshState uniq r x
-> Maybe x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ContFreshState uniq r x -> x
forall uniq (r :: [(* -> *) -> * -> *]) a.
ContFreshState uniq r a -> a
getResult)
          (Union r (Sem (Cont (ViaFreshRef uniq) : r)) x
-> Union
     (Error (uniq, Any) : r) (Sem (Cont (ViaFreshRef uniq) : r)) x
forall (e :: (* -> *) -> * -> *) (r :: [(* -> *) -> * -> *])
       (m :: * -> *) a.
Union r m a -> Union (e : r) m a
weaken Union r (Sem (Cont (ViaFreshRef uniq) : r)) x
g)
      let loop :: x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
loop x
x = x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
c x
x Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
-> ((uniq, Any)
    -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
`catch` ((uniq, Any) -> Sem (Error (uniq, Any) : r) x
h ((uniq, Any) -> Sem (Error (uniq, Any) : r) x)
-> (x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> (uniq, Any)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
loop)
      ResAndHandler s
res (uniq, Any) -> Sem (Error (uniq, Any) : r) s
h' <- x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
loop x
a
      -- TODO(KingoftheHomeless): This handler is dubious.
      ContFreshState uniq r s
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
forall (m :: * -> *) a. Monad m => a -> m a
return (s
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
-> ContFreshState uniq r s
forall uniq (r :: [(* -> *) -> * -> *]) a.
a
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) a)
-> ContFreshState uniq r a
ResAndHandler s
res (((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
 -> ContFreshState uniq r s)
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
-> ContFreshState uniq r s
forall a b. (a -> b) -> a -> b
$ \(uniq, Any)
x -> ((uniq, Any) -> Sem (Error (uniq, Any) : r) s
h' (uniq, Any)
x Sem (Error (uniq, Any) : r) s
-> ((uniq, Any) -> Sem (Error (uniq, Any) : r) s)
-> Sem (Error (uniq, Any) : r) s
forall e (r :: [(* -> *) -> * -> *]) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
`catch` ((uniq, Any) -> Sem (Error (uniq, Any) : r) x
h ((uniq, Any) -> Sem (Error (uniq, Any) : r) x)
-> (x -> Sem (Error (uniq, Any) : r) s)
-> (uniq, Any)
-> Sem (Error (uniq, Any) : r) s
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (ContFreshState uniq r s -> s)
-> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
-> Sem (Error (uniq, Any) : r) s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ContFreshState uniq r s -> s
forall uniq (r :: [(* -> *) -> * -> *]) a.
ContFreshState uniq r a -> a
getResult (Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
 -> Sem (Error (uniq, Any) : r) s)
-> (x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s))
-> x
-> Sem (Error (uniq, Any) : r) s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. x -> Sem (Error (uniq, Any) : r) (ContFreshState uniq r s)
loop)))

-- | This is the effectful state used by 'runContViaFreshInC' when weaving through
-- other effectful actions. The point of it is to avoid delimiting computations
-- in higher-order effects, by having them return a handler which may be used
-- to intercept backtrack exceptions of the current continuation.
data ContFreshState uniq r a = ResAndHandler {
    ContFreshState uniq r a -> a
getResult :: a
  , ContFreshState uniq r a
-> (uniq, Any) -> Sem (Error (uniq, Any) : r) a
getHandler :: (uniq, Any) -> Sem (Error (uniq, Any) ': r) a
  }
  deriving a -> ContFreshState uniq r b -> ContFreshState uniq r a
(a -> b) -> ContFreshState uniq r a -> ContFreshState uniq r b
(forall a b.
 (a -> b) -> ContFreshState uniq r a -> ContFreshState uniq r b)
-> (forall a b.
    a -> ContFreshState uniq r b -> ContFreshState uniq r a)
-> Functor (ContFreshState uniq r)
forall uniq (r :: [(* -> *) -> * -> *]) a b.
a -> ContFreshState uniq r b -> ContFreshState uniq r a
forall uniq (r :: [(* -> *) -> * -> *]) a b.
(a -> b) -> ContFreshState uniq r a -> ContFreshState uniq r b
forall a b. a -> ContFreshState uniq r b -> ContFreshState uniq r a
forall a b.
(a -> b) -> ContFreshState uniq r a -> ContFreshState uniq r b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ContFreshState uniq r b -> ContFreshState uniq r a
$c<$ :: forall uniq (r :: [(* -> *) -> * -> *]) a b.
a -> ContFreshState uniq r b -> ContFreshState uniq r a
fmap :: (a -> b) -> ContFreshState uniq r a -> ContFreshState uniq r b
$cfmap :: forall uniq (r :: [(* -> *) -> * -> *]) a b.
(a -> b) -> ContFreshState uniq r a -> ContFreshState uniq r b
Functor