{-# LANGUAGE DeriveTraversable, FlexibleInstances, LambdaCase, MultiParamTypeClasses, RankNTypes, TypeOperators, 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 qualified 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 qualified Data.Semigroup as S
import Prelude hiding (head, tail)

-- | Run a 'Choose' effect with continuations respectively interpreting '<|>' and 'pure'.
--
-- @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 fork :: m b -> m b -> m b
fork leaf :: a -> m b
leaf (ChooseC runChooseC :: 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

-- | 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.<>))

-- | 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
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 (\ _ leaf :: a -> m b
leaf -> a -> m b
leaf a
a)
  {-# INLINE pure #-}
  ChooseC f :: 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 a :: 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
$ \ fork :: m b -> m b -> m b
fork leaf :: 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 (\ f' :: 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 a :: forall b. (m b -> m b -> m b) -> (a -> m b) -> m b
a >>= :: ChooseC m a -> (a -> ChooseC m b) -> ChooseC m b
>>= f :: 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
$ \ fork :: m b -> m b -> m b
fork leaf :: 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 s :: 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 f :: 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
$ \ fork :: m b -> m b -> m b
fork leaf :: 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:|[] -> 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 :: 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
$ \ fork :: m b -> m b -> m b
fork leaf :: 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 :: 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 :: 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 (\ _ leaf :: 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, Effect sig) => Algebra (Choose :+: sig) (ChooseC m) where
  alg :: (:+:) Choose sig (ChooseC m) a -> ChooseC m a
alg (L (Choose k :: Bool -> ChooseC m a
k)) = (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
$ \ fork :: m b -> m b -> m b
fork leaf :: a -> m b
leaf -> 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 (Bool -> ChooseC m a
k Bool
True)) ((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 (Bool -> ChooseC m a
k Bool
False))
  alg (R other :: sig (ChooseC m) a
other)      = (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
$ \ fork :: m b -> m b -> m b
fork leaf :: a -> m b
leaf -> sig m (ChooseC Identity a) -> m (ChooseC Identity a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Algebra sig m =>
sig m a -> m a
alg (ChooseC Identity ()
-> (forall x.
    ChooseC Identity (ChooseC m x) -> m (ChooseC Identity x))
-> sig (ChooseC m) a
-> sig m (ChooseC Identity a)
forall (sig :: (* -> *) -> * -> *) (ctx :: * -> *) (m :: * -> *)
       (n :: * -> *) a.
(Effect sig, Functor ctx, Monad m) =>
ctx ()
-> (forall x. ctx (m x) -> n (ctx x)) -> sig m a -> sig n (ctx a)
thread (() -> ChooseC Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) 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 sig (ChooseC m) a
other) m (ChooseC Identity a) -> (ChooseC Identity 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
runIdentity (Identity (m b) -> m b)
-> (ChooseC Identity a -> Identity (m b))
-> ChooseC Identity a
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Identity (m b) -> Identity (m b) -> Identity (m b))
-> (a -> Identity (m b)) -> ChooseC Identity 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)
forall a b. Coercible a b => a -> b
coerce m b -> m b -> m b
fork) ((a -> m b) -> a -> Identity (m b)
forall a b. Coercible a b => a -> b
coerce 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
runIdentity (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 #-}