{-# LANGUAGE UndecidableInstances #-}

{- | An effect modelling nondeterminism without failure (one or more successful results).

The 'Control.Effect.NonDet.NonDet' effect is the composition of 'Choose' and 'Empty'.

Predefined carriers:

* "Control.Carrier.Choose.Church".
* If 'Choose' is the last effect in a stack, it can be interpreted directly to a 'NonEmpty'.

@since 1.0.0.0
-}

module Control.Effect.Choose
( -- * Choose effect
  Choose(..)
, (<|>)
, optional
, many
, some
, some1
  -- * Choosing semigroup
, Choosing(..)
  -- * Re-exports
, Algebra
, Has
, run
) where

import           Control.Algebra
import           Control.Effect.Choose.Internal (Choose(..))
import           Control.Effect.Empty
import           Data.Bool (bool)
import           Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Semigroup as S

-- | Nondeterministically choose between two computations.
--
-- @
-- (m '<|>' n) '>>=' k = (m '>>=' k) '<|>' (n '>>=' k)
-- @
-- @
-- (m '<|>' n) '<|>' o = m '<|>' (n '<|>' o)
-- @
-- @
-- 'empty' '<|>' m = m
-- @
-- @
-- m '<|>' 'empty' = m
-- @
--
-- @since 1.0.0.0
(<|>) :: Has Choose sig m => m a -> m a -> m a
m a
a <|> :: m a -> m a -> m a
<|> m a
b = Choose m Bool -> m Bool
forall (eff :: (* -> *) -> * -> *) (sig :: (* -> *) -> * -> *)
       (m :: * -> *) a.
(Member eff sig, Algebra sig m) =>
eff m a -> m a
send Choose m Bool
forall (m :: * -> *). Choose m Bool
Choose m Bool -> (Bool -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> m a -> Bool -> m a
forall a. a -> a -> Bool -> a
bool m a
b m a
a
{-# INLINE (<|>) #-}

infixl 3 <|>

-- | Select between 'Just' the result of an operation, and 'Nothing'.
--
-- @
-- 'optional' 'empty' = 'pure' 'Nothing'
-- @
-- @
-- 'optional' ('pure' a) = 'pure' ('Just' a)
-- @
--
-- @since 1.0.0.0
optional :: Has Choose sig m => m a -> m (Maybe a)
optional :: m a -> m (Maybe a)
optional m a
a = a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> m a -> m (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
a m (Maybe a) -> m (Maybe a) -> m (Maybe a)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Choose sig m =>
m a -> m a -> m a
<|> Maybe a -> m (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
{-# INLINE optional #-}

-- | Zero or more.
--
-- @
-- 'many' m = 'some' m '<|>' 'pure' []
-- @
--
-- @since 1.0.0.0
many :: Has Choose sig m => m a -> m [a]
many :: m a -> m [a]
many m a
a = m [a]
go where go :: m [a]
go = (:) (a -> [a] -> [a]) -> m a -> m ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
a m ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m [a]
go m [a] -> m [a] -> m [a]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Choose sig m =>
m a -> m a -> m a
<|> [a] -> m [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
{-# INLINE many #-}

-- | One or more.
--
-- @
-- 'some' m = (:) '<$>' m '<*>' 'many' m
-- @
--
-- @since 1.0.0.0
some :: Has Choose sig m => m a -> m [a]
some :: m a -> m [a]
some m a
a = (:) (a -> [a] -> [a]) -> m a -> m ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
a m ([a] -> [a]) -> m [a] -> m [a]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a -> m [a]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Choose sig m =>
m a -> m [a]
many m a
a
{-# INLINE some #-}

-- | One or more, returning a 'NonEmpty' list of the results.
--
-- @
-- 'some1' m = (':|') '<$>' m '<*>' 'many' m
-- @
--
-- @since 1.0.0.0
some1 :: Has Choose sig m => m a -> m (NonEmpty a)
some1 :: m a -> m (NonEmpty a)
some1 m a
a = a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(:|) (a -> [a] -> NonEmpty a) -> m a -> m ([a] -> NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a
a m ([a] -> NonEmpty a) -> m [a] -> m (NonEmpty a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m a -> m [a]
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Choose sig m =>
m a -> m [a]
many m a
a
{-# INLINE some1 #-}


-- | @since 1.0.0.0
newtype Choosing m a = Choosing { Choosing m a -> m a
getChoosing :: m a }

instance Has Choose sig m => S.Semigroup (Choosing m a) where
  Choosing m a
m1 <> :: Choosing m a -> Choosing m a -> Choosing m a
<> Choosing m a
m2 = m a -> Choosing m a
forall (m :: * -> *) a. m a -> Choosing m a
Choosing (m a
m1 m a -> m a -> m a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Choose sig m =>
m a -> m a -> m a
<|> m a
m2)
  {-# INLINE (<>) #-}

instance (Has Choose sig m, Has Empty sig m) => Monoid (Choosing m a) where
  mempty :: Choosing m a
mempty = m a -> Choosing m a
forall (m :: * -> *) a. m a -> Choosing m a
Choosing m a
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has Empty sig m =>
m a
empty
  {-# INLINE mempty #-}

  mappend :: Choosing m a -> Choosing m a -> Choosing m a
mappend = Choosing m a -> Choosing m a -> Choosing m a
forall a. Semigroup a => a -> a -> a
(S.<>)
  {-# INLINE mappend #-}