{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- | A carrier for 'Choose' effects (nondeterminism without failure).

Under the hood, it uses a Church-encoded binary tree to avoid the problems associated with a naïve list-based implementation (see ["ListT done right"](http://wiki.haskell.org/ListT_done_right)).

@since 1.0.0.0
-}

module Control.Carrier.Choose.Church
( -- * Choose carrier
  runChoose
, runChooseS
, ChooseC(..)
  -- * Choose effect
, module Control.Effect.Choose
) where

import Control.Algebra
import Control.Applicative (liftA2)
import Control.Effect.Choose
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
import Data.List.NonEmpty (NonEmpty(..), head, tail)
import Data.Semigroup as S
import Prelude hiding (head, tail)

-- | Run a 'Choose' effect with continuations respectively interpreting '<|>' and 'pure'.
--
-- @
-- runChoose fork leaf ('pure' a '<|>' b) = leaf a \`fork\` 'runChoose' fork leaf b
-- @
--
-- @since 1.0.0.0
runChoose :: (m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
runChoose :: (m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
runChoose m b -> m b -> m b
fork a -> m b
leaf (ChooseC forall b. (m b -> m b -> m b) -> (a -> m b) -> m b
runChooseC) = (m b -> m b -> m b) -> (a -> m b) -> m b
forall b. (m b -> m b -> m b) -> (a -> m b) -> m b
runChooseC m b -> m b -> m b
fork a -> m b
leaf
{-# INLINE runChoose #-}

-- | Run a 'Choose' effect, mapping results into a 'S.Semigroup'.
--
-- @since 1.0.0.0
runChooseS :: (S.Semigroup b, Applicative m) => (a -> m b) -> ChooseC m a -> m b
runChooseS :: (a -> m b) -> ChooseC m a -> m b
runChooseS = (m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
runChoose ((b -> b -> b) -> m b -> m b -> m b
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> b -> b
forall a. Semigroup a => a -> a -> a
(S.<>))
{-# INLINE runChooseS #-}

-- | A carrier for 'Choose' effects based on Ralf Hinze’s design described in [Deriving Backtracking Monad Transformers](https://www.cs.ox.ac.uk/ralf.hinze/publications/#P12).
--
-- @since 1.0.0.0
newtype ChooseC m a = ChooseC (forall b . (m b -> m b -> m b) -> (a -> m b) -> m b)
  deriving (a -> ChooseC m b -> ChooseC m a
(a -> b) -> ChooseC m a -> ChooseC m b
(forall a b. (a -> b) -> ChooseC m a -> ChooseC m b)
-> (forall a b. a -> ChooseC m b -> ChooseC m a)
-> Functor (ChooseC m)
forall a b. a -> ChooseC m b -> ChooseC m a
forall a b. (a -> b) -> ChooseC m a -> ChooseC 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 -> ChooseC m b -> ChooseC m a
forall (m :: * -> *) a b. (a -> b) -> ChooseC m a -> ChooseC m b
<$ :: a -> ChooseC m b -> ChooseC m a
$c<$ :: forall (m :: * -> *) a b. a -> ChooseC m b -> ChooseC m a
fmap :: (a -> b) -> ChooseC m a -> ChooseC m b
$cfmap :: forall (m :: * -> *) a b. (a -> b) -> ChooseC m a -> ChooseC m b
Functor)

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

  ChooseC forall b. (m b -> m b -> m b) -> ((a -> b) -> m b) -> m b
f <*> :: ChooseC m (a -> b) -> ChooseC m a -> ChooseC m b
<*> ChooseC forall b. (m b -> m b -> m b) -> (a -> m b) -> m b
a = (forall b. (m b -> m b -> m b) -> (b -> m b) -> m b) -> ChooseC m b
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b) -> ChooseC m a
ChooseC ((forall b. (m b -> m b -> m b) -> (b -> m b) -> m b)
 -> ChooseC m b)
-> (forall b. (m b -> m b -> m b) -> (b -> m b) -> m b)
-> ChooseC m b
forall a b. (a -> b) -> a -> b
$ \ m b -> m b -> m b
fork b -> m b
leaf ->
    (m b -> m b -> m b) -> ((a -> b) -> m b) -> m b
forall b. (m b -> m b -> m b) -> ((a -> b) -> m b) -> m b
f m b -> m b -> m b
fork (\ a -> b
f' -> (m b -> m b -> m b) -> (a -> m b) -> m b
forall b. (m b -> m b -> m b) -> (a -> m b) -> m b
a m b -> m b -> m b
fork (b -> m b
leaf (b -> m b) -> (a -> b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f'))
  {-# INLINE (<*>) #-}

instance Monad (ChooseC m) where
  ChooseC forall b. (m b -> m b -> m b) -> (a -> m b) -> m b
a >>= :: ChooseC m a -> (a -> ChooseC m b) -> ChooseC m b
>>= a -> ChooseC m b
f = (forall b. (m b -> m b -> m b) -> (b -> m b) -> m b) -> ChooseC m b
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b) -> ChooseC m a
ChooseC ((forall b. (m b -> m b -> m b) -> (b -> m b) -> m b)
 -> ChooseC m b)
-> (forall b. (m b -> m b -> m b) -> (b -> m b) -> m b)
-> ChooseC m b
forall a b. (a -> b) -> a -> b
$ \ m b -> m b -> m b
fork b -> m b
leaf ->
    (m b -> m b -> m b) -> (a -> m b) -> m b
forall b. (m b -> m b -> m b) -> (a -> m b) -> m b
a m b -> m b -> m b
fork ((m b -> m b -> m b) -> (b -> m b) -> ChooseC m b -> m b
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
runChoose m b -> m b -> m b
fork b -> m b
leaf (ChooseC m b -> m b) -> (a -> ChooseC m b) -> a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ChooseC m b
f)
  {-# INLINE (>>=) #-}

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

-- | Separate fixpoints are computed for each branch.
instance MonadFix m => MonadFix (ChooseC m) where
  mfix :: (a -> ChooseC m a) -> ChooseC m a
mfix a -> ChooseC m a
f = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b) -> ChooseC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b) -> ChooseC m a
ChooseC ((forall b. (m b -> m b -> m b) -> (a -> m b) -> m b)
 -> ChooseC m a)
-> (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b)
-> ChooseC m a
forall a b. (a -> b) -> a -> b
$ \ m b -> m b -> m b
fork a -> m b
leaf ->
    (NonEmpty a -> m (NonEmpty a)) -> m (NonEmpty a)
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix ((a -> m (NonEmpty a)) -> ChooseC m a -> m (NonEmpty a)
forall b (m :: * -> *) a.
(Semigroup b, Applicative m) =>
(a -> m b) -> ChooseC m a -> m b
runChooseS (NonEmpty a -> m (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty a -> m (NonEmpty a))
-> (a -> NonEmpty a) -> a -> m (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (ChooseC m a -> m (NonEmpty a))
-> (NonEmpty a -> ChooseC m a) -> NonEmpty a -> m (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ChooseC m a
f (a -> ChooseC m a)
-> (NonEmpty a -> a) -> NonEmpty a -> ChooseC m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty a -> a
forall a. NonEmpty a -> a
head)
    m (NonEmpty a) -> (NonEmpty a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      a
a:|[] -> a -> m b
leaf a
a
      a
a:|[a]
_  -> a -> m b
leaf a
a m b -> m b -> m b
`fork` (m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
runChoose m b -> m b -> m b
fork a -> m b
leaf ((a -> ChooseC m a) -> ChooseC m a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (m [a] -> ChooseC m a
forall (m :: * -> *) (t :: * -> *) a.
(Monad m, Foldable t, Functor t) =>
m (t a) -> ChooseC m a
liftAll (m [a] -> ChooseC m a) -> (a -> m [a]) -> a -> ChooseC m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty a -> [a]) -> m (NonEmpty a) -> m [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty a -> [a]
forall a. NonEmpty a -> [a]
tail (m (NonEmpty a) -> m [a]) -> (a -> m (NonEmpty a)) -> a -> m [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m (NonEmpty a)) -> ChooseC m a -> m (NonEmpty a)
forall b (m :: * -> *) a.
(Semigroup b, Applicative m) =>
(a -> m b) -> ChooseC m a -> m b
runChooseS (NonEmpty a -> m (NonEmpty a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty a -> m (NonEmpty a))
-> (a -> NonEmpty a) -> a -> m (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (ChooseC m a -> m (NonEmpty a))
-> (a -> ChooseC m a) -> a -> m (NonEmpty a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ChooseC m a
f))
      where
    liftAll :: m (t a) -> ChooseC m a
liftAll m (t a)
m = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b) -> ChooseC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b) -> ChooseC m a
ChooseC ((forall b. (m b -> m b -> m b) -> (a -> m b) -> m b)
 -> ChooseC m a)
-> (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b)
-> ChooseC m a
forall a b. (a -> b) -> a -> b
$ \ m b -> m b -> m b
fork a -> m b
leaf -> m (t a)
m m (t a) -> (t a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (m b -> m b -> m b) -> t (m b) -> m b
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 m b -> m b -> m b
fork (t (m b) -> m b) -> (t a -> t (m b)) -> t a -> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> m b) -> t a -> t (m b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> m b
leaf
  {-# INLINE mfix #-}

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

instance MonadTrans ChooseC where
  lift :: m a -> ChooseC m a
lift m a
m = (forall b. (m b -> m b -> m b) -> (a -> m b) -> m b) -> ChooseC m a
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b) -> ChooseC m a
ChooseC (\ m b -> m b -> m b
_ a -> m b
leaf -> m a
m m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> m b
leaf)
  {-# INLINE lift #-}

instance Algebra sig m => Algebra (Choose :+: sig) (ChooseC m) where
  alg :: Handler ctx n (ChooseC m)
-> (:+:) Choose sig n a -> ctx () -> ChooseC m (ctx a)
alg Handler ctx n (ChooseC m)
hdl (:+:) Choose sig n a
sig ctx ()
ctx = (forall b. (m b -> m b -> m b) -> (ctx a -> m b) -> m b)
-> ChooseC m (ctx a)
forall (m :: * -> *) a.
(forall b. (m b -> m b -> m b) -> (a -> m b) -> m b) -> ChooseC m a
ChooseC ((forall b. (m b -> m b -> m b) -> (ctx a -> m b) -> m b)
 -> ChooseC m (ctx a))
-> (forall b. (m b -> m b -> m b) -> (ctx a -> m b) -> m b)
-> ChooseC m (ctx a)
forall a b. (a -> b) -> a -> b
$ \ m b -> m b -> m b
fork ctx a -> m b
leaf -> case (:+:) Choose sig n a
sig of
    L Choose n a
Choose -> ctx a -> m b
leaf (Bool
True Bool -> ctx () -> ctx Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx) m b -> m b -> m b
`fork` ctx a -> m b
leaf (Bool
False Bool -> ctx () -> ctx Bool
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ctx ()
ctx)
    R sig n a
other  -> Handler (Compose (ChooseC Identity) ctx) n m
-> sig n a
-> ChooseC Identity (ctx ())
-> m (ChooseC Identity (ctx a))
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 x. ChooseC Identity (ChooseC m x) -> m (ChooseC Identity x)
forall (m :: * -> *) a.
Applicative m =>
ChooseC Identity (ChooseC m a) -> m (ChooseC Identity a)
dst (forall x.
 ChooseC Identity (ChooseC m x) -> m (ChooseC Identity x))
-> Handler ctx n (ChooseC m)
-> Handler (Compose (ChooseC Identity) ctx) n m
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 (ChooseC m)
hdl) sig n a
other (ctx () -> ChooseC Identity (ctx ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure ctx ()
ctx) m (ChooseC Identity (ctx a))
-> (ChooseC Identity (ctx a) -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Identity (m b) -> m b
forall a. Identity a -> a
run (Identity (m b) -> m b)
-> (ChooseC Identity (ctx a) -> Identity (m b))
-> ChooseC Identity (ctx a)
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity (m b) -> Identity (m b) -> Identity (m b))
-> (ctx a -> Identity (m b))
-> ChooseC Identity (ctx a)
-> Identity (m b)
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
runChoose ((m b -> m b -> m b)
-> Identity (m b) -> Identity (m b) -> Identity (m b)
coerce m b -> m b -> m b
fork) ((ctx a -> m b) -> ctx a -> Identity (m b)
coerce ctx a -> m b
leaf)
    where
    dst :: Applicative m => ChooseC Identity (ChooseC m a) -> m (ChooseC Identity a)
    dst :: ChooseC Identity (ChooseC m a) -> m (ChooseC Identity a)
dst = Identity (m (ChooseC Identity a)) -> m (ChooseC Identity a)
forall a. Identity a -> a
run (Identity (m (ChooseC Identity a)) -> m (ChooseC Identity a))
-> (ChooseC Identity (ChooseC m a)
    -> Identity (m (ChooseC Identity a)))
-> ChooseC Identity (ChooseC m a)
-> m (ChooseC Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity (m (ChooseC Identity a))
 -> Identity (m (ChooseC Identity a))
 -> Identity (m (ChooseC Identity a)))
-> (ChooseC m a -> Identity (m (ChooseC Identity a)))
-> ChooseC Identity (ChooseC m a)
-> Identity (m (ChooseC Identity a))
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
runChoose ((m (ChooseC Identity a)
 -> m (ChooseC Identity a) -> m (ChooseC Identity a))
-> Identity (m (ChooseC Identity a))
-> Identity (m (ChooseC Identity a))
-> Identity (m (ChooseC Identity a))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ((ChooseC Identity a -> ChooseC Identity a -> ChooseC Identity a)
-> m (ChooseC Identity a)
-> m (ChooseC Identity a)
-> m (ChooseC Identity a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ChooseC Identity a -> ChooseC Identity a -> ChooseC Identity a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Choose sig m =>
m a -> m a -> m a
(<|>))) (m (ChooseC Identity a) -> Identity (m (ChooseC Identity a))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (m (ChooseC Identity a) -> Identity (m (ChooseC Identity a)))
-> (ChooseC m a -> m (ChooseC Identity a))
-> ChooseC m a
-> Identity (m (ChooseC Identity a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m (ChooseC Identity a)
 -> m (ChooseC Identity a) -> m (ChooseC Identity a))
-> (a -> m (ChooseC Identity a))
-> ChooseC m a
-> m (ChooseC Identity a)
forall (m :: * -> *) b a.
(m b -> m b -> m b) -> (a -> m b) -> ChooseC m a -> m b
runChoose ((ChooseC Identity a -> ChooseC Identity a -> ChooseC Identity a)
-> m (ChooseC Identity a)
-> m (ChooseC Identity a)
-> m (ChooseC Identity a)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 ChooseC Identity a -> ChooseC Identity a -> ChooseC Identity a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Choose sig m =>
m a -> m a -> m a
(<|>)) (ChooseC Identity a -> m (ChooseC Identity a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ChooseC Identity a -> m (ChooseC Identity a))
-> (a -> ChooseC Identity a) -> a -> m (ChooseC Identity a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ChooseC Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure))
  {-# INLINE alg #-}