{-# LANGUAGE DerivingVia #-}
{-# OPTIONS_HADDOCK not-home #-}
module Control.Effect.Internal.Select where

import Control.Effect
import Control.Effect.Cont

-- For coercion purposes

import Control.Effect.Carrier
import Control.Effect.Carrier.Internal.Compose
import Control.Effect.Internal.Cont
import Control.Monad.Trans.Free.Church.Alternate

-- | An effect for backtracking search.

newtype Select s m a where
  Select :: (forall r. (a -> m (s, r)) -> m r) -> Select s m a

-- | Perform a search: capture the continuation

-- of the program, so that you may test values of @a@ and observe

-- what corresponding @s@ each value would result in

-- at the end of the program (which may be seen as the evaluation of @a@).

-- When you find a satisfactory @a@, you may return the associated @r@.

--

-- The way higher-order actions interact with the continuation depends

-- on the interpretation of 'Select'. In general, you cannot expect to interact

-- with the continuation in any meaningful way: for example, you should not

-- assume that you will be able to catch an exception thrown at some point in

-- the future of the computation by using 'Control.Effect.Error.catch' on the

-- continuation.

select :: Eff (Select s) m
       => (forall r. (a -> m (s, r)) -> m r) -> m a
select :: (forall r. (a -> m (s, r)) -> m r) -> m a
select forall r. (a -> m (s, r)) -> m r
main = Select s m a -> m a
forall (e :: Effect) (m :: * -> *) a.
(Member e (Derivs m), Carrier m) =>
e m a -> m a
send ((forall r. (a -> m (s, r)) -> m r) -> Select s m a
forall a (m :: * -> *) s.
(forall r. (a -> m (s, r)) -> m r) -> Select s m a
Select forall r. (a -> m (s, r)) -> m r
main)
{-# INLINE select #-}

data SelectH r

instance Eff (Shift (s, r)) m
      => Handler (SelectH r) (Select s) m where
  effHandler :: Select s (Effly z) x -> Effly z x
effHandler = \case
    Select forall r. (x -> Effly z (s, r)) -> Effly z r
main -> forall r (m :: * -> *) a.
Eff (Shift r) m =>
((a -> m r) -> m r) -> m a
forall (m :: * -> *) a.
Eff (Shift (s, r)) m =>
((a -> m (s, r)) -> m (s, r)) -> m a
shift @(s, r) (((x -> Effly z (s, r)) -> Effly z (s, r)) -> Effly z x)
-> ((x -> Effly z (s, r)) -> Effly z (s, r)) -> Effly z x
forall a b. (a -> b) -> a -> b
$ \x -> Effly z (s, r)
c ->
      (x -> Effly z (s, (s, r))) -> Effly z (s, r)
forall r. (x -> Effly z (s, r)) -> Effly z r
main ((x -> Effly z (s, (s, r))) -> Effly z (s, r))
-> (x -> Effly z (s, (s, r))) -> Effly z (s, r)
forall a b. (a -> b) -> a -> b
$ \x
a -> (\(s
s,r
r) -> (s
s, (s
s, r
r))) ((s, r) -> (s, (s, r))) -> Effly z (s, r) -> Effly z (s, (s, r))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> x -> Effly z (s, r)
c x
a
  {-# INLINEABLE effHandler #-}

newtype SelectC s r m a = SelectC {
    SelectC s r m a
-> ReinterpretC
     (SelectH r) (Select s) '[Shift (s, r)] (ShiftC (s, r) m) a
unSelectC ::
        ReinterpretC (SelectH r) (Select s) '[Shift (s, r)]
      ( ShiftC (s, r)
      ( m
      )) a
  } deriving ( a -> SelectC s r m b -> SelectC s r m a
(a -> b) -> SelectC s r m a -> SelectC s r m b
(forall a b. (a -> b) -> SelectC s r m a -> SelectC s r m b)
-> (forall a b. a -> SelectC s r m b -> SelectC s r m a)
-> Functor (SelectC s r m)
forall a b. a -> SelectC s r m b -> SelectC s r m a
forall a b. (a -> b) -> SelectC s r m a -> SelectC s r m b
forall s r (m :: * -> *) a b.
a -> SelectC s r m b -> SelectC s r m a
forall s r (m :: * -> *) a b.
(a -> b) -> SelectC s r m a -> SelectC s r m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> SelectC s r m b -> SelectC s r m a
$c<$ :: forall s r (m :: * -> *) a b.
a -> SelectC s r m b -> SelectC s r m a
fmap :: (a -> b) -> SelectC s r m a -> SelectC s r m b
$cfmap :: forall s r (m :: * -> *) a b.
(a -> b) -> SelectC s r m a -> SelectC s r m b
Functor, Functor (SelectC s r m)
a -> SelectC s r m a
Functor (SelectC s r m)
-> (forall a. a -> SelectC s r m a)
-> (forall a b.
    SelectC s r m (a -> b) -> SelectC s r m a -> SelectC s r m b)
-> (forall a b c.
    (a -> b -> c)
    -> SelectC s r m a -> SelectC s r m b -> SelectC s r m c)
-> (forall a b.
    SelectC s r m a -> SelectC s r m b -> SelectC s r m b)
-> (forall a b.
    SelectC s r m a -> SelectC s r m b -> SelectC s r m a)
-> Applicative (SelectC s r m)
SelectC s r m a -> SelectC s r m b -> SelectC s r m b
SelectC s r m a -> SelectC s r m b -> SelectC s r m a
SelectC s r m (a -> b) -> SelectC s r m a -> SelectC s r m b
(a -> b -> c)
-> SelectC s r m a -> SelectC s r m b -> SelectC s r m c
forall a. a -> SelectC s r m a
forall a b. SelectC s r m a -> SelectC s r m b -> SelectC s r m a
forall a b. SelectC s r m a -> SelectC s r m b -> SelectC s r m b
forall a b.
SelectC s r m (a -> b) -> SelectC s r m a -> SelectC s r m b
forall a b c.
(a -> b -> c)
-> SelectC s r m a -> SelectC s r m b -> SelectC s r m c
forall s r (m :: * -> *). Functor (SelectC s r m)
forall s r (m :: * -> *) a. a -> SelectC s r m a
forall s r (m :: * -> *) a b.
SelectC s r m a -> SelectC s r m b -> SelectC s r m a
forall s r (m :: * -> *) a b.
SelectC s r m a -> SelectC s r m b -> SelectC s r m b
forall s r (m :: * -> *) a b.
SelectC s r m (a -> b) -> SelectC s r m a -> SelectC s r m b
forall s r (m :: * -> *) a b c.
(a -> b -> c)
-> SelectC s r m a -> SelectC s r m b -> SelectC s r m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: SelectC s r m a -> SelectC s r m b -> SelectC s r m a
$c<* :: forall s r (m :: * -> *) a b.
SelectC s r m a -> SelectC s r m b -> SelectC s r m a
*> :: SelectC s r m a -> SelectC s r m b -> SelectC s r m b
$c*> :: forall s r (m :: * -> *) a b.
SelectC s r m a -> SelectC s r m b -> SelectC s r m b
liftA2 :: (a -> b -> c)
-> SelectC s r m a -> SelectC s r m b -> SelectC s r m c
$cliftA2 :: forall s r (m :: * -> *) a b c.
(a -> b -> c)
-> SelectC s r m a -> SelectC s r m b -> SelectC s r m c
<*> :: SelectC s r m (a -> b) -> SelectC s r m a -> SelectC s r m b
$c<*> :: forall s r (m :: * -> *) a b.
SelectC s r m (a -> b) -> SelectC s r m a -> SelectC s r m b
pure :: a -> SelectC s r m a
$cpure :: forall s r (m :: * -> *) a. a -> SelectC s r m a
$cp1Applicative :: forall s r (m :: * -> *). Functor (SelectC s r m)
Applicative, Applicative (SelectC s r m)
a -> SelectC s r m a
Applicative (SelectC s r m)
-> (forall a b.
    SelectC s r m a -> (a -> SelectC s r m b) -> SelectC s r m b)
-> (forall a b.
    SelectC s r m a -> SelectC s r m b -> SelectC s r m b)
-> (forall a. a -> SelectC s r m a)
-> Monad (SelectC s r m)
SelectC s r m a -> (a -> SelectC s r m b) -> SelectC s r m b
SelectC s r m a -> SelectC s r m b -> SelectC s r m b
forall a. a -> SelectC s r m a
forall a b. SelectC s r m a -> SelectC s r m b -> SelectC s r m b
forall a b.
SelectC s r m a -> (a -> SelectC s r m b) -> SelectC s r m b
forall s r (m :: * -> *). Applicative (SelectC s r m)
forall s r (m :: * -> *) a. a -> SelectC s r m a
forall s r (m :: * -> *) a b.
SelectC s r m a -> SelectC s r m b -> SelectC s r m b
forall s r (m :: * -> *) a b.
SelectC s r m a -> (a -> SelectC s r m b) -> SelectC s r m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> SelectC s r m a
$creturn :: forall s r (m :: * -> *) a. a -> SelectC s r m a
>> :: SelectC s r m a -> SelectC s r m b -> SelectC s r m b
$c>> :: forall s r (m :: * -> *) a b.
SelectC s r m a -> SelectC s r m b -> SelectC s r m b
>>= :: SelectC s r m a -> (a -> SelectC s r m b) -> SelectC s r m b
$c>>= :: forall s r (m :: * -> *) a b.
SelectC s r m a -> (a -> SelectC s r m b) -> SelectC s r m b
$cp1Monad :: forall s r (m :: * -> *). Applicative (SelectC s r m)
Monad
             , Monad (SelectC s r m)
Monad (SelectC s r m)
-> (forall a. String -> SelectC s r m a)
-> MonadFail (SelectC s r m)
String -> SelectC s r m a
forall a. String -> SelectC s r m a
forall s r (m :: * -> *). MonadFail m => Monad (SelectC s r m)
forall s r (m :: * -> *) a.
MonadFail m =>
String -> SelectC s r m a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: String -> SelectC s r m a
$cfail :: forall s r (m :: * -> *) a.
MonadFail m =>
String -> SelectC s r m a
$cp1MonadFail :: forall s r (m :: * -> *). MonadFail m => Monad (SelectC s r m)
MonadFail, Monad (SelectC s r m)
Monad (SelectC s r m)
-> (forall a. IO a -> SelectC s r m a) -> MonadIO (SelectC s r m)
IO a -> SelectC s r m a
forall a. IO a -> SelectC s r m a
forall s r (m :: * -> *). MonadIO m => Monad (SelectC s r m)
forall s r (m :: * -> *) a. MonadIO m => IO a -> SelectC s r m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> SelectC s r m a
$cliftIO :: forall s r (m :: * -> *) a. MonadIO m => IO a -> SelectC s r m a
$cp1MonadIO :: forall s r (m :: * -> *). MonadIO m => Monad (SelectC s r m)
MonadIO
             , Monad (SelectC s r m)
e -> SelectC s r m a
Monad (SelectC s r m)
-> (forall e a. Exception e => e -> SelectC s r m a)
-> MonadThrow (SelectC s r m)
forall e a. Exception e => e -> SelectC s r m a
forall s r (m :: * -> *). MonadThrow m => Monad (SelectC s r m)
forall s r (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> SelectC s r m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> SelectC s r m a
$cthrowM :: forall s r (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> SelectC s r m a
$cp1MonadThrow :: forall s r (m :: * -> *). MonadThrow m => Monad (SelectC s r m)
MonadThrow, MonadThrow (SelectC s r m)
MonadThrow (SelectC s r m)
-> (forall e a.
    Exception e =>
    SelectC s r m a -> (e -> SelectC s r m a) -> SelectC s r m a)
-> MonadCatch (SelectC s r m)
SelectC s r m a -> (e -> SelectC s r m a) -> SelectC s r m a
forall e a.
Exception e =>
SelectC s r m a -> (e -> SelectC s r m a) -> SelectC s r m a
forall s r (m :: * -> *).
MonadCatch m =>
MonadThrow (SelectC s r m)
forall s r (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
SelectC s r m a -> (e -> SelectC s r m a) -> SelectC s r m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: SelectC s r m a -> (e -> SelectC s r m a) -> SelectC s r m a
$ccatch :: forall s r (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
SelectC s r m a -> (e -> SelectC s r m a) -> SelectC s r m a
$cp1MonadCatch :: forall s r (m :: * -> *).
MonadCatch m =>
MonadThrow (SelectC s r m)
MonadCatch
             , MonadBase b
             )
    deriving m a -> SelectC s r m a
(forall (m :: * -> *) a. Monad m => m a -> SelectC s r m a)
-> MonadTrans (SelectC s r)
forall s r (m :: * -> *) a. Monad m => m a -> SelectC s r m a
forall (m :: * -> *) a. Monad m => m a -> SelectC s r m a
forall (t :: Effect).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> SelectC s r m a
$clift :: forall s r (m :: * -> *) a. Monad m => m a -> SelectC s r m a
MonadTrans
    via CompositionBaseT
     '[ ReinterpretC (SelectH r) (Select s) '[Shift (s, r)]
      , ShiftC (s, r)
      ]

deriving instance (Carrier m, Threads (FreeT (ContBase (m (s, r)) (s, r))) (Prims m))
               => Carrier (SelectC s r m)

-- | Run a @'Select' s@ effect by providing an evaluator

-- for the final result of type @a@.

--

--  @'Derivs' ('SelectC' s r m) = 'Select' s ': 'Derivs' m@

--

--  @'Control.Effect.Primitive.Prims'  ('SelectC' s r m) = 'Control.Effect.Primitive.Prims' m@

runSelect :: forall s a m p
           . (Carrier m, Threaders '[ContThreads] m p)
          => (a -> m s)
          -> SelectC s a m a
          -> m a
runSelect :: (a -> m s) -> SelectC s a m a -> m a
runSelect a -> m s
c SelectC s a m a
m =
    ((s, a) -> a) -> m (s, a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (s, a) -> a
forall a b. (a, b) -> b
snd
  (m (s, a) -> m a) -> m (s, a) -> m a
forall a b. (a -> b) -> a -> b
$ ShiftC (s, a) m (s, a) -> m (s, a)
forall r (m :: * -> *) (p :: [Effect]).
(Carrier m, Threaders '[ContThreads] m p) =>
ShiftC r m r -> m r
runShift
  (ShiftC (s, a) m (s, a) -> m (s, a))
-> ShiftC (s, a) m (s, a) -> m (s, a)
forall a b. (a -> b) -> a -> b
$ (ShiftC (s, a) m a
-> (a -> ShiftC (s, a) m (s, a)) -> ShiftC (s, a) m (s, a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \a
a -> (\s
s -> (s
s, a
a)) (s -> (s, a)) -> ShiftC (s, a) m s -> ShiftC (s, a) m (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s -> ShiftC (s, a) m s
forall (t :: Effect) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (a -> m s
c a
a))
  (ShiftC (s, a) m a -> ShiftC (s, a) m (s, a))
-> ShiftC (s, a) m a -> ShiftC (s, a) m (s, a)
forall a b. (a -> b) -> a -> b
$ ReinterpretC
  (SelectH a) (Select s) '[Shift (s, a)] (ShiftC (s, a) m) a
-> ShiftC (s, a) m a
forall h (e :: Effect) (new :: [Effect]) (m :: * -> *) a.
(Handler h e m, KnownList new, HeadEffs new m) =>
ReinterpretC h e new m a -> m a
reinterpretViaHandler
  (ReinterpretC
   (SelectH a) (Select s) '[Shift (s, a)] (ShiftC (s, a) m) a
 -> ShiftC (s, a) m a)
-> ReinterpretC
     (SelectH a) (Select s) '[Shift (s, a)] (ShiftC (s, a) m) a
-> ShiftC (s, a) m a
forall a b. (a -> b) -> a -> b
$ SelectC s a m a
-> ReinterpretC
     (SelectH a) (Select s) '[Shift (s, a)] (ShiftC (s, a) m) a
forall s r (m :: * -> *) a.
SelectC s r m a
-> ReinterpretC
     (SelectH r) (Select s) '[Shift (s, r)] (ShiftC (s, r) m) a
unSelectC
  (SelectC s a m a
 -> ReinterpretC
      (SelectH a) (Select s) '[Shift (s, a)] (ShiftC (s, a) m) a)
-> SelectC s a m a
-> ReinterpretC
     (SelectH a) (Select s) '[Shift (s, a)] (ShiftC (s, a) m) a
forall a b. (a -> b) -> a -> b
$ SelectC s a m a
m
{-# INLINE runSelect #-}