Choose.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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 qualified Control.Applicative as A
import           Control.Effect.Choose.Internal (Choose(..))
import           Control.Effect.Empty
import           Control.Monad (MonadPlus)
import           Control.Monad.Fail as Fail
import           Control.Monad.Fix
import           Control.Monad.IO.Class (MonadIO)
import           Control.Monad.IO.Unlift (MonadUnliftIO)
import           Control.Monad.Trans.Class (MonadTrans(..))
import           Control.Monad.Zip
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
a <|> b = send Choose >>= bool b 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 a = Just <$> a <|> pure 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 a = go where go = (:) <$> a <*> go <|> 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 a = (:) <$> a <*> many 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 a = (:|) <$> a <*> many a
{-# INLINE some1 #-}


-- | @since 1.0.0.0
newtype Choosing m a = Choosing { getChoosing :: m a }
  deriving (Algebra sig, Applicative, Foldable, Functor, Monad, Fail.MonadFail, MonadFix, MonadIO, MonadUnliftIO, MonadZip)

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

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

  mappend = (S.<>)
  {-# INLINE mappend #-}

instance (Has Choose sig m, Has Empty sig m) => A.Alternative (Choosing m) where
  empty = mempty
  {-# INLINE empty #-}

  (<|>) = mappend
  {-# INLINE (<|>) #-}

instance (Has Choose sig m, Has Empty sig m) => MonadPlus (Choosing m)

instance MonadTrans Choosing where
  lift = Choosing
  {-# INLINE lift #-}

instance Traversable m => Traversable (Choosing m) where
  sequenceA (Choosing m) = fmap Choosing (sequenceA m)
  {-# INLINE sequenceA #-}

  traverse f (Choosing m) = fmap Choosing (traverse f m)
  {-# INLINE traverse #-}

  sequence (Choosing m) = fmap Choosing (sequence m)
  {-# INLINE sequence #-}

  mapM f (Choosing m) = fmap Choosing (mapM f m)
  {-# INLINE mapM #-}