add SelectT monad transformer
authorRoss Paterson <ross@soi.city.ac.uk>
Fri, 17 Feb 2017 00:01:18 +0000 (00:01 +0000)
committerRoss Paterson <ross@soi.city.ac.uk>
Fri, 17 Feb 2017 00:01:18 +0000 (00:01 +0000)
Control/Monad/Trans/Class.hs
Control/Monad/Trans/Select.hs [new file with mode: 0644]
transformers.cabal

index d7f26cc..9c2e260 100644 (file)
@@ -69,12 +69,13 @@ unwrap the transformer, exposing a computation of the inner monad.
 major release they will be separate functions.)
 
 All of the monad transformers except 'Control.Monad.Trans.Cont.ContT'
-are functors on the category of monads: in addition to defining a
-mapping of monads, they also define a mapping from transformations
-between base monads to transformations between transformed monads,
-called @map@/XXX/@T@.  Thus given a monad transformation @t :: M a -> N a@,
-the combinator 'Control.Monad.Trans.State.Lazy.mapStateT' constructs
-a monad transformation
+and 'Control.Monad.Trans.Cont.SelectT' are functors on the category
+of monads: in addition to defining a mapping of monads, they
+also define a mapping from transformations between base monads to
+transformations between transformed monads, called @map@/XXX/@T@.
+Thus given a monad transformation @t :: M a -> N a@, the combinator
+'Control.Monad.Trans.State.Lazy.mapStateT' constructs a monad
+transformation
 
 > mapStateT t :: StateT s M a -> StateT s N a
 
diff --git a/Control/Monad/Trans/Select.hs b/Control/Monad/Trans/Select.hs
new file mode 100644 (file)
index 0000000..12a798e
--- /dev/null
@@ -0,0 +1,133 @@
+{-# 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,
+    -- * The SelectT monad transformer
+    SelectT(SelectT),
+    runSelectT,
+    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 #-}
+
+-- | 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 #-}
+
+instance (Functor m) => Functor (SelectT r m) where
+    fmap f (SelectT g) = SelectT (fmap f . g . (. f))
+    {-# INLINE fmap #-}
+
+instance (Monad m) => Applicative (SelectT r m) where
+    pure = lift . pure
+    {-# INLINE pure #-}
+    SelectT gf <*> SelectT gx = SelectT $ \ k -> do
+        let h f = liftM f (gx (k . f))
+        f <- gf ((>>= k) . h)
+        h f
+    {-# INLINE (<*>) #-}
+
+instance (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 = pure
+    {-# 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.
+selectToCont :: (Monad m) => SelectT r m a -> ContT r m a
+selectToCont (SelectT g) = ContT $ \ k -> g k >>= k
+{-# INLINE selectToCont #-}
index 56c8db7..74c6fe5 100644 (file)
@@ -77,6 +77,7 @@ library
     Control.Monad.Trans.RWS
     Control.Monad.Trans.RWS.Lazy
     Control.Monad.Trans.RWS.Strict
+    Control.Monad.Trans.Select
     Control.Monad.Trans.State
     Control.Monad.Trans.State.Lazy
     Control.Monad.Trans.State.Strict