module Control.Effect.Select
  ( -- * Effect
    Select(..)

    -- * Actions
  , select

    -- * Interpretations
  , runSelect
  , runSelectFast

    -- * Carriers
  , SelectC
  , SelectFastC
  ) where

import Control.Effect
import Control.Effect.Cont

-- | An effect for backtracking search.
data 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 #-}

type SelectC s r = CompositionC
 '[ ReinterpretC (SelectH r) (Select s) '[Shift (s, r)]
  , ShiftC (s, r)
  ]

type SelectFastC s r = CompositionC
 '[ ReinterpretC (SelectH r) (Select s) '[Shift (s, r)]
  , ShiftFastC (s, r)
  ]

-- | 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
-> CompositionBaseM
     '[ReinterpretC (SelectH a) (Select s) '[Shift (s, a)],
       ShiftC (s, a)]
     m
     a
forall (ts :: [Effect]) (m :: * -> *) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition
  (SelectC s a m a
 -> CompositionBaseM
      '[ReinterpretC (SelectH a) (Select s) '[Shift (s, a)],
        ShiftC (s, a)]
      m
      a)
-> SelectC s a m a
-> CompositionBaseM
     '[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 #-}

-- | Run a @'Select' s@ effect by providing an evaluator
-- for the final result of type @a@.
--
-- Compared to 'runSelect', this is quite a bit faster, but is significantly
-- more restrictive in what interpreters are used after it, since there are
-- very few primitive effects that the carrier for 'runSelectFast' is able to
-- thread.
-- In fact, of all the primitive effects featured in this library, only
-- one satisfies 'ContFastThreads': namely, 'Control.Effect.Reader.Reader'.
--
--  @'Derivs' ('SelectFastC' s r m) = 'Select' s ': 'Derivs' m@
--
--  @'Control.Effect.Primitive.Prims'  ('SelectFastC' s r m) = 'Control.Effect.Primitive.Prims' m@
runSelectFast :: forall s a m p
               . (Carrier m, Threaders '[ContFastThreads] m p)
              => (a -> m s)
              -> SelectFastC s a m a
              -> m a
runSelectFast :: (a -> m s) -> SelectFastC s a m a -> m a
runSelectFast a -> m s
c SelectFastC 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
$ ShiftFastC (s, a) m (s, a) -> m (s, a)
forall r (m :: * -> *) (p :: [Effect]).
(Carrier m, Threaders '[ContFastThreads] m p) =>
ShiftFastC r m r -> m r
runShiftFast
  (ShiftFastC (s, a) m (s, a) -> m (s, a))
-> ShiftFastC (s, a) m (s, a) -> m (s, a)
forall a b. (a -> b) -> a -> b
$ (ShiftFastC (s, a) m a
-> (a -> ShiftFastC (s, a) m (s, a)) -> ShiftFastC (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))
-> ShiftFastC (s, a) m s -> ShiftFastC (s, a) m (s, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m s -> ShiftFastC (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))
  (ShiftFastC (s, a) m a -> ShiftFastC (s, a) m (s, a))
-> ShiftFastC (s, a) m a -> ShiftFastC (s, a) m (s, a)
forall a b. (a -> b) -> a -> b
$ ReinterpretC
  (SelectH a) (Select s) '[Shift (s, a)] (ShiftFastC (s, a) m) a
-> ShiftFastC (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)] (ShiftFastC (s, a) m) a
 -> ShiftFastC (s, a) m a)
-> ReinterpretC
     (SelectH a) (Select s) '[Shift (s, a)] (ShiftFastC (s, a) m) a
-> ShiftFastC (s, a) m a
forall a b. (a -> b) -> a -> b
$ SelectFastC s a m a
-> CompositionBaseM
     '[ReinterpretC (SelectH a) (Select s) '[Shift (s, a)],
       ShiftFastC (s, a)]
     m
     a
forall (ts :: [Effect]) (m :: * -> *) a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition
  (SelectFastC s a m a
 -> CompositionBaseM
      '[ReinterpretC (SelectH a) (Select s) '[Shift (s, a)],
        ShiftFastC (s, a)]
      m
      a)
-> SelectFastC s a m a
-> CompositionBaseM
     '[ReinterpretC (SelectH a) (Select s) '[Shift (s, a)],
       ShiftFastC (s, a)]
     m
     a
forall a b. (a -> b) -> a -> b
$ SelectFastC s a m a
m
{-# INLINE runSelectFast #-}