Control/Monad/Trans/Select.hs

    {-# LANGUAGE CPP #-}
    #if __GLASGOW_HASKELL__ >= 702
    {-# LANGUAGE Safe #-}
    #endif
    #if __GLASGOW_HASKELL__ >= 706
    {-# LANGUAGE PolyKinds #-}
    #endif
    #if __GLASGOW_HASKELL__ >= 710
    {-# LANGUAGE AutoDeriveTypeable #-}
    #endif
    -----------------------------------------------------------------------------
    -- |
    -- Module      :  Control.Monad.Trans.Select
    -- Copyright   :  (c) Ross Paterson 2017
    -- License     :  BSD-style (see the file LICENSE)
    --
    -- Maintainer  :  R.Paterson@city.ac.uk
    -- Stability   :  experimental
    -- Portability :  portable
    --
    -- Selection monad transformer, modelling search algorithms.
    --
    -- * Martin Escardo and Paulo Oliva.
    --   "Selection functions, bar recursion and backward induction",
    --   /Mathematical Structures in Computer Science/ 20:2 (2010), pp. 127-168.
    --   <https://www.cs.bham.ac.uk/~mhe/papers/selection-escardo-oliva.pdf>
    --
    -- * Jules Hedges. "Monad transformers for backtracking search".
    --   In /Proceedings of MSFP 2014/. <https://arxiv.org/abs/1406.2058>
    -----------------------------------------------------------------------------

    module Control.Monad.Trans.Select (
        -- * The Select monad
        Select,
        select,
        runSelect,
        mapSelect,
        -- * The SelectT monad transformer
        SelectT(SelectT),
        runSelectT,
        mapSelectT,
        -- * Monad transformation
        selectToContT,
        selectToCont,
        ) where

    import Control.Monad.IO.Class
    import Control.Monad.Trans.Class
    import Control.Monad.Trans.Cont

    import Control.Applicative
    import Control.Monad
    #if MIN_VERSION_base(4,9,0)
    import qualified Control.Monad.Fail as Fail
    #endif
    import Data.Functor.Identity

    -- | Selection monad.
    type Select r = SelectT r Identity

    -- | Constructor for computations in the selection monad.
    select :: ((a -> r) -> a) -> Select r a
    select f = SelectT $ \ k -> Identity (f (runIdentity . k))
    {-# INLINE select #-}

    -- | Runs a @Select@ computation with a function for evaluating answers
    -- to select a particular answer.  (The inverse of 'select'.)
    runSelect :: Select r a -> (a -> r) -> a
    runSelect m k = runIdentity (runSelectT m (Identity . k))
    {-# INLINE runSelect #-}

    -- | Apply a function to transform the result of a selection computation.
    --
    -- * @'runSelect' ('mapSelect' f m) = f . 'runSelect' m@
    mapSelect :: (a -> a) -> Select r a -> Select r a
    mapSelect f = mapSelectT (Identity . f . runIdentity)
    {-# INLINE mapSelect #-}

    -- | Selection monad transformer.
    --
    -- 'SelectT' is not a functor on the category of monads, and many operations
    -- cannot be lifted through it.
    newtype SelectT r m a = SelectT ((a -> m r) -> m a)

    -- | Runs a @SelectT@ computation with a function for evaluating answers
    -- to select a particular answer.  (The inverse of 'select'.)
    runSelectT :: SelectT r m a -> (a -> m r) -> m a
    runSelectT (SelectT g) = g
    {-# INLINE runSelectT #-}

    -- | Apply a function to transform the result of a selection computation.
    -- This has a more restricted type than the @map@ operations for other
    -- monad transformers, because 'SelectT' does not define a functor in
    -- the category of monads.
    --
    -- * @'runSelectT' ('mapSelectT' f m) = f . 'runSelectT' m@
    mapSelectT :: (m a -> m a) -> SelectT r m a -> SelectT r m a
    mapSelectT f m = SelectT $ f . runSelectT m
    {-# INLINE mapSelectT #-}

    instance (Functor m) => Functor (SelectT r m) where
        fmap f (SelectT g) = SelectT (fmap f . g . (. f))
        {-# INLINE fmap #-}

    instance (Functor m, Monad m) => Applicative (SelectT r m) where
        pure = lift . return
        {-# INLINE pure #-}
        SelectT gf <*> SelectT gx = SelectT $ \ k -> do
            let h f = liftM f (gx (k . f))
            f <- gf ((>>= k) . h)
            h f
        {-# INLINE (<*>) #-}
        m *> k = m >>= \_ -> k
        {-# INLINE (*>) #-}

    instance (Functor m, MonadPlus m) => Alternative (SelectT r m) where
        empty = mzero
        {-# INLINE empty #-}
        (<|>) = mplus
        {-# INLINE (<|>) #-}

    instance (Monad m) => Monad (SelectT r m) where
    #if !(MIN_VERSION_base(4,8,0))
        return = lift . return
        {-# INLINE return #-}
    #endif
        SelectT g >>= f = SelectT $ \ k -> do
            let h x = runSelectT (f x) k
            y <- g ((>>= k) . h)
            h y
        {-# INLINE (>>=) #-}

    #if MIN_VERSION_base(4,9,0)
    instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where
        fail msg = lift (Fail.fail msg)
        {-# INLINE fail #-}
    #endif

    instance (MonadPlus m) => MonadPlus (SelectT r m) where
        mzero = SelectT (const mzero)
        {-# INLINE mzero #-}
        SelectT f `mplus` SelectT g = SelectT $ \ k -> f k `mplus` g k
        {-# INLINE mplus #-}

    instance MonadTrans (SelectT r) where
        lift = SelectT . const
        {-# INLINE lift #-}

    instance (MonadIO m) => MonadIO (SelectT r m) where
        liftIO = lift . liftIO
        {-# INLINE liftIO #-}

    -- | Convert a selection computation to a continuation-passing computation.
    selectToContT :: (Monad m) => SelectT r m a -> ContT r m a
    selectToContT (SelectT g) = ContT $ \ k -> g k >>= k
    {-# INLINE selectToCont #-}

    -- | Deprecated name for 'selectToContT'.
    {-# DEPRECATED selectToCont "Use selectToContT instead" #-}
    selectToCont :: (Monad m) => SelectT r m a -> ContT r m a
    selectToCont = selectToContT