{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | A carrier for 'Cut' and 'NonDet' effects used in tandem (@Cut :+: NonDet@).
--
-- @since 1.0.0.0
module Control.Carrier.Cut.Church
( -- * Cut carrier
  runCut
, runCutA
, runCutM
, CutC(..)
  -- * Cut effect
, module Control.Effect.Cut
  -- * NonDet effects
, module Control.Effect.NonDet
) where

import Control.Algebra
import Control.Applicative (liftA2)
import Control.Effect.Cut
import Control.Effect.NonDet
import Control.Monad.Fail as Fail
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Data.Coerce (coerce)
import Data.Functor.Identity

-- | Run a 'Cut' effect with continuations respectively interpreting 'pure' / '<|>', 'empty', and 'cutfail'.
--
-- @
-- runCut cons nil fail ('pure' a '<|>' 'empty') = cons a nil
-- @
-- @
-- runCut cons nil fail 'cutfail' = fail
-- @
-- @
-- runCut cons nil fail ('call' 'cutfail') = nil
-- @
--
-- @since 1.0.0.0
runCut :: (a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut :: forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut a -> m b -> m b
cons m b
nil m b
fail (CutC forall b. (a -> m b -> m b) -> m b -> m b -> m b
runCutC) = forall b. (a -> m b -> m b) -> m b -> m b -> m b
runCutC a -> m b -> m b
cons m b
nil m b
fail
{-# INLINE runCut #-}

-- | Run a 'Cut' effect, returning all its results in an 'Alternative' collection.
--
-- @since 1.0.0.0
runCutA :: (Alternative f, Applicative m) => CutC m a -> m (f a)
runCutA :: forall (f :: * -> *) (m :: * -> *) a.
(Alternative f, Applicative m) =>
CutC m a -> m (f a)
runCutA = forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Alternative f => f a
empty) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Alternative f => f a
empty)
{-# INLINE runCutA #-}

-- | Run a 'Cut' effect, mapping results into a 'Monoid'.
--
-- @since 1.0.0.0
runCutM :: (Applicative m, Monoid b) => (a -> b) -> CutC m a -> m b
runCutM :: forall (m :: * -> *) b a.
(Applicative m, Monoid b) =>
(a -> b) -> CutC m a -> m b
runCutM a -> b
leaf = forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => a -> a -> a
mappend forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
leaf) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty)
{-# INLINE runCutM #-}

-- | @since 1.0.0.0
newtype CutC m a = CutC (forall b . (a -> m b -> m b) -> m b -> m b -> m b)
  deriving (forall a b. a -> CutC m b -> CutC m a
forall a b. (a -> b) -> CutC m a -> CutC m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> CutC m b -> CutC m a
forall (m :: * -> *) a b. (a -> b) -> CutC m a -> CutC m b
<$ :: forall a b. a -> CutC m b -> CutC m a
$c<$ :: forall (m :: * -> *) a b. a -> CutC m b -> CutC m a
fmap :: forall a b. (a -> b) -> CutC m a -> CutC m b
$cfmap :: forall (m :: * -> *) a b. (a -> b) -> CutC m a -> CutC m b
Functor)

instance Applicative (CutC m) where
  pure :: forall a. a -> CutC m a
pure a
a = forall (m :: * -> *) a.
(forall b. (a -> m b -> m b) -> m b -> m b -> m b) -> CutC m a
CutC (\ a -> m b -> m b
cons m b
nil m b
_ -> a -> m b -> m b
cons a
a m b
nil)
  {-# INLINE pure #-}

  CutC forall b. ((a -> b) -> m b -> m b) -> m b -> m b -> m b
f <*> :: forall a b. CutC m (a -> b) -> CutC m a -> CutC m b
<*> CutC forall b. (a -> m b -> m b) -> m b -> m b -> m b
a = forall (m :: * -> *) a.
(forall b. (a -> m b -> m b) -> m b -> m b -> m b) -> CutC m a
CutC forall a b. (a -> b) -> a -> b
$ \ b -> m b -> m b
cons m b
nil m b
fail ->
    forall b. ((a -> b) -> m b -> m b) -> m b -> m b -> m b
f (\ a -> b
f' m b
fs -> forall b. (a -> m b -> m b) -> m b -> m b -> m b
a (b -> m b -> m b
cons forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f') m b
fs m b
fail) m b
nil m b
fail
  {-# INLINE (<*>) #-}

instance Alternative (CutC m) where
  empty :: forall a. CutC m a
empty = forall (m :: * -> *) a.
(forall b. (a -> m b -> m b) -> m b -> m b -> m b) -> CutC m a
CutC (\ a -> m b -> m b
_ m b
nil m b
_ -> m b
nil)
  {-# INLINE empty #-}

  CutC forall b. (a -> m b -> m b) -> m b -> m b -> m b
l <|> :: forall a. CutC m a -> CutC m a -> CutC m a
<|> CutC forall b. (a -> m b -> m b) -> m b -> m b -> m b
r = forall (m :: * -> *) a.
(forall b. (a -> m b -> m b) -> m b -> m b -> m b) -> CutC m a
CutC (\ a -> m b -> m b
cons m b
nil m b
fail -> forall b. (a -> m b -> m b) -> m b -> m b -> m b
l a -> m b -> m b
cons (forall b. (a -> m b -> m b) -> m b -> m b -> m b
r a -> m b -> m b
cons m b
nil m b
fail) m b
fail)
  {-# INLINE (<|>) #-}

instance Monad (CutC m) where
  CutC forall b. (a -> m b -> m b) -> m b -> m b -> m b
a >>= :: forall a b. CutC m a -> (a -> CutC m b) -> CutC m b
>>= a -> CutC m b
f = forall (m :: * -> *) a.
(forall b. (a -> m b -> m b) -> m b -> m b -> m b) -> CutC m a
CutC forall a b. (a -> b) -> a -> b
$ \ b -> m b -> m b
cons m b
nil m b
fail ->
    forall b. (a -> m b -> m b) -> m b -> m b -> m b
a (\ a
a' m b
as -> forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut b -> m b -> m b
cons m b
as m b
fail (a -> CutC m b
f a
a')) m b
nil m b
fail
  {-# INLINE (>>=) #-}

instance Fail.MonadFail m => Fail.MonadFail (CutC m) where
  fail :: forall a. String -> CutC m a
fail String
s = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
s)
  {-# INLINE fail #-}

-- | A single fixpoint is shared between all branches.
instance MonadFix m => MonadFix (CutC m) where
  mfix :: forall a. (a -> CutC m a) -> CutC m a
mfix a -> CutC m a
f = forall (m :: * -> *) a.
(forall b. (a -> m b -> m b) -> m b -> m b -> m b) -> CutC m a
CutC forall a b. (a -> b) -> a -> b
$ \ a -> m b -> m b
cons m b
nil m b
fail -> forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix
    (forall {a}. CutC m a -> m (CutC Identity a)
toCut forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> CutC m a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {b}. CutC Identity b -> Identity b
fromCut)
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> m b -> m b
cons) (forall (f :: * -> *) a. Applicative f => a -> f a
pure m b
nil) (forall (f :: * -> *) a. Applicative f => a -> f a
pure m b
fail) where
    toCut :: CutC m a -> m (CutC Identity a)
toCut = forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Alternative f => f a
empty) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Cut sig m =>
m a
cutfail)
    fromCut :: CutC Identity b -> Identity b
fromCut = forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) (forall a. HasCallStack => String -> a
error String
"mfix CutC: empty") (forall a. HasCallStack => String -> a
error String
"mfix CutC: cutfail")
  {-# INLINE mfix #-}

instance MonadIO m => MonadIO (CutC m) where
  liftIO :: forall a. IO a -> CutC m a
liftIO IO a
io = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io)
  {-# INLINE liftIO #-}

instance MonadPlus (CutC m)

instance MonadTrans CutC where
  lift :: forall (m :: * -> *) a. Monad m => m a -> CutC m a
lift m a
m = forall (m :: * -> *) a.
(forall b. (a -> m b -> m b) -> m b -> m b -> m b) -> CutC m a
CutC (\ a -> m b -> m b
cons m b
nil m b
_ -> m a
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> m b -> m b
cons m b
nil)
  {-# INLINE lift #-}

instance Algebra sig m => Algebra (Cut :+: NonDet :+: sig) (CutC m) where
  alg :: forall (ctx :: * -> *) (n :: * -> *) a.
Functor ctx =>
Handler ctx n (CutC m)
-> (:+:) Cut (NonDet :+: sig) n a -> ctx () -> CutC m (ctx a)
alg Handler ctx n (CutC m)
hdl (:+:) Cut (NonDet :+: sig) n a
sig ctx ()
ctx = forall (m :: * -> *) a.
(forall b. (a -> m b -> m b) -> m b -> m b -> m b) -> CutC m a
CutC forall a b. (a -> b) -> a -> b
$ \ ctx a -> m b -> m b
cons m b
nil m b
fail -> case (:+:) Cut (NonDet :+: sig) n a
sig of
    L Cut n a
Cutfail        -> m b
fail
    L (Call n a
m)       -> forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut ctx a -> m b -> m b
cons m b
nil m b
nil (Handler ctx n (CutC m)
hdl (n a
m forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx))
    R (L (L Empty n a
Empty))  -> m b
nil
    R (L (R Choose n a
Choose)) -> ctx a -> m b -> m b
cons (Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) (ctx a -> m b -> m b
cons (Bool
False forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) m b
nil)
    R (R sig n a
other)      -> forall (ctx1 :: * -> *) (ctx2 :: * -> *)
       (sig :: (* -> *) -> * -> *) (m :: * -> *) (n :: * -> *) a.
(Functor ctx1, Functor ctx2, Algebra sig m) =>
Handler (Compose ctx1 ctx2) n m
-> sig n a -> ctx1 (ctx2 ()) -> m (ctx1 (ctx2 a))
thread (forall (m :: * -> *) a.
Applicative m =>
CutC Identity (CutC m a) -> m (CutC Identity a)
dst forall (n :: * -> *) (ctx1 :: * -> *) (m :: * -> *)
       (ctx2 :: * -> *) (l :: * -> *).
(Functor n, Functor ctx1) =>
Handler ctx1 m n
-> Handler ctx2 l m -> Handler (Compose ctx1 ctx2) l n
~<~ Handler ctx n (CutC m)
hdl) sig n a
other (forall (f :: * -> *) a. Applicative f => a -> f a
pure ctx ()
ctx) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut (coerce :: forall a b. Coercible a b => a -> b
coerce ctx a -> m b -> m b
cons) (coerce :: forall a b. Coercible a b => a -> b
coerce m b
nil) (coerce :: forall a b. Coercible a b => a -> b
coerce m b
fail)
    where
    dst :: Applicative m => CutC Identity (CutC m a) -> m (CutC Identity a)
    dst :: forall (m :: * -> *) a.
Applicative m =>
CutC Identity (CutC m a) -> m (CutC Identity a)
dst = forall a. Identity a -> a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *) b.
(a -> m b -> m b) -> m b -> m b -> CutC m a -> m b
runCut (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Alternative f => f a
empty) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Cut sig m =>
m a
cutfail)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a. Alternative f => f a
empty)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Cut sig m =>
m a
cutfail))
  {-# INLINE alg #-}