Choice.hs

{-# Language MultiParamTypeClasses #-}
{-# Language FlexibleInstances #-}

{-|
Module     : Control.Monad.Class.Choice
Copyright  : (c) Eamon Olive, 2020
             (c) Louis Hyde,  2020
License    : AGPL-3
Maintainer : ejolive97@gmail.com
Stability  : experimental

-}
module Control.Monad.Class.Choice
  ( MonadChoice (..)
  , chooseM
  )
  where

import Control.Monad
  ( join
  )
import Control.Monad.Random.Class
  ( MonadRandom
  , uniform
  )
import Control.Monad.Trans
  ( lift
  )
import Control.Monad.Trans.Accum
  ( AccumT
  )
import Control.Monad.Trans.Cont
  ( ContT
  )
import Control.Monad.Trans.Except
  ( ExceptT
  )
import Control.Monad.Trans.Identity
  ( IdentityT
  )
import Control.Monad.Trans.Maybe
  ( MaybeT
  )
import Control.Monad.Trans.Reader
  ( ReaderT
  )
import Control.Monad.Trans.RWS.CPS as RWS.CPS
  ( RWST
  )
import Control.Monad.Trans.RWS.Lazy as RWS.Lazy
  ( RWST
  )
import Control.Monad.Trans.RWS.Strict as RWS.Strict
  ( RWST
  )
import Control.Monad.Trans.Select
  ( SelectT
  )
import Control.Monad.Trans.State.Lazy as State.Lazy
  ( StateT
  )
import Control.Monad.Trans.State.Strict as State.Strict
  ( StateT
  )
import Control.Monad.Trans.Writer.CPS as Writer.CPS
  ( WriterT
  )
import Control.Monad.Trans.Writer.Lazy as Writer.Lazy
  ( WriterT
  )
import Control.Monad.Trans.Writer.Strict as Writer.Strict
  ( WriterT
  )

-- | A monad with a series of dependent choices.
-- It is usually desirable to have @f@ be a 'Foldable' so that a selection can be made from it.
--
-- As an example here is a simple berry name generator:
--
-- > berry :: MonadChoice NonEmpty m => m String
-- > berry = do
-- >   color  <- choose $ "red" :| ["blue", "pink", "cyan"]
-- >   prefix <- choose $ "color" :| ["straw", "rasp", "cran"]
-- >   return $ prefix ++ "berry"
--
-- Since this has a polymorphic type this could be used for a variety of purposes.
class Monad m => MonadChoice f m where
  -- | Makes a selection.
  choose :: f a -> m a

-- | Makes a selection where options are themselves selections.
chooseM ::
  ( MonadChoice f m
  )
    => f (m a) -> m a
chooseM = join . choose

instance (Foldable f, MonadRandom m) => MonadChoice f m where
  choose = uniform

instance MonadChoice f m => MonadChoice f (MaybeT m) where
  choose = lift . choose 

instance MonadChoice f m => MonadChoice f (ExceptT e m) where
  choose = lift . choose 

instance MonadChoice f m => MonadChoice f (IdentityT m) where
  choose = lift . choose 

instance MonadChoice f m => MonadChoice f (State.Lazy.StateT s m) where
  choose = lift . choose

instance MonadChoice f m => MonadChoice f (State.Strict.StateT s m) where
  choose = lift . choose

instance MonadChoice f m => MonadChoice f (ReaderT r m) where
  choose = lift . choose

instance MonadChoice f m => MonadChoice f (Writer.CPS.WriterT w m) where
  choose = lift . choose

instance (Monoid w, MonadChoice f m) => MonadChoice f (Writer.Lazy.WriterT w m) where
  choose = lift . choose

instance (Monoid w, MonadChoice f m) => MonadChoice f (Writer.Strict.WriterT w m) where
  choose = lift . choose

instance (Monoid w, MonadChoice f m) => MonadChoice f (AccumT w m) where
  choose = lift . choose

instance MonadChoice f m => MonadChoice f (ContT r m) where
  choose = lift . choose

instance (Monoid w, MonadChoice f m) => MonadChoice f (RWS.Lazy.RWST r w s m) where
  choose = lift . choose

instance (Monoid w, MonadChoice f m) => MonadChoice f (RWS.Strict.RWST r w s m) where
  choose = lift . choose

instance MonadChoice f m => MonadChoice f (RWS.CPS.RWST r w s m) where
  choose = lift . choose

instance MonadChoice f m => MonadChoice f (SelectT r m) where
  choose = lift . choose