1{-# LANGUAGE CPP #-} 2 3# ifndef HASKELL98 4{-# LANGUAGE DeriveDataTypeable #-} 5{-# LANGUAGE StandaloneDeriving #-} 6# if __GLASGOW_HASKELL__ >= 704 7{-# LANGUAGE Safe #-} 8# elif __GLASGOW_HASKELL__ >= 702 9{-# LANGUAGE Trustworthy #-} 10# endif 11# if __GLASGOW_HASKELL__ >= 706 12{-# LANGUAGE PolyKinds #-} 13# endif 14# if __GLASGOW_HASKELL__ >= 708 15{-# LANGUAGE AutoDeriveTypeable #-} 16{-# LANGUAGE DataKinds #-} 17# endif 18#endif 19----------------------------------------------------------------------------- 20-- | 21-- Module : Control.Monad.Trans.Select 22-- Copyright : (c) Ross Paterson 2017 23-- License : BSD-style (see the file LICENSE) 24-- 25-- Maintainer : R.Paterson@city.ac.uk 26-- Stability : experimental 27-- Portability : portable 28-- 29-- Selection monad transformer, modelling search algorithms. 30-- 31-- * Martin Escardo and Paulo Oliva. 32-- "Selection functions, bar recursion and backward induction", 33-- /Mathematical Structures in Computer Science/ 20:2 (2010), pp. 127-168. 34-- <https://www.cs.bham.ac.uk/~mhe/papers/selection-escardo-oliva.pdf> 35-- 36-- * Jules Hedges. "Monad transformers for backtracking search". 37-- In /Proceedings of MSFP 2014/. <https://arxiv.org/abs/1406.2058> 38----------------------------------------------------------------------------- 39 40module Control.Monad.Trans.Select ( 41 -- * The Select monad 42 Select, 43 select, 44 runSelect, 45 mapSelect, 46 -- * The SelectT monad transformer 47 SelectT(SelectT), 48 runSelectT, 49 mapSelectT, 50 -- * Monad transformation 51 selectToContT, 52 selectToCont, 53 ) where 54 55import Control.Monad.IO.Class 56import Control.Monad.Trans.Class 57import Control.Monad.Trans.Cont 58 59import Control.Applicative 60import Control.Monad 61import qualified Control.Monad.Fail as Fail 62import Data.Functor.Identity 63 64#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 65import Data.Typeable 66#endif 67 68-- | Selection monad. 69type Select r = SelectT r Identity 70 71-- | Constructor for computations in the selection monad. 72select :: ((a -> r) -> a) -> Select r a 73select f = SelectT $ \ k -> Identity (f (runIdentity . k)) 74{-# INLINE select #-} 75 76-- | Runs a @Select@ computation with a function for evaluating answers 77-- to select a particular answer. (The inverse of 'select'.) 78runSelect :: Select r a -> (a -> r) -> a 79runSelect m k = runIdentity (runSelectT m (Identity . k)) 80{-# INLINE runSelect #-} 81 82-- | Selection monad transformer. 83-- 84-- 'SelectT' is not a functor on the category of monads, and many operations 85-- cannot be lifted through it. 86newtype SelectT r m a = SelectT ((a -> m r) -> m a) 87 88-- | Runs a @SelectT@ computation with a function for evaluating answers 89-- to select a particular answer. (The inverse of 'select'.) 90runSelectT :: SelectT r m a -> (a -> m r) -> m a 91runSelectT (SelectT g) = g 92{-# INLINE runSelectT #-} 93 94-- | Apply a function to transform the result of a selection computation. 95-- This has a more restricted type than the @map@ operations for other 96-- monad transformers, because 'SelectT' does not define a functor in 97-- the category of monads. 98-- 99-- * @'runSelectT' ('mapSelectT' f m) = f . 'runSelectT' m@ 100mapSelectT :: (m a -> m a) -> SelectT r m a -> SelectT r m a 101mapSelectT f m = SelectT $ f . runSelectT m 102{-# INLINE mapSelectT #-} 103 104-- | Apply a function to transform the result of a selection computation. 105-- 106-- * @'runSelect' ('mapSelect' f m) = f . 'runSelect' m@ 107mapSelect :: (a -> a) -> Select r a -> Select r a 108mapSelect f = mapSelectT (Identity . f . runIdentity) 109{-# INLINE mapSelect #-} 110 111instance (Functor m) => Functor (SelectT r m) where 112 fmap f (SelectT g) = SelectT (fmap f . g . (. f)) 113 {-# INLINE fmap #-} 114 115instance (Functor m, Monad m) => Applicative (SelectT r m) where 116 pure = lift . return 117 {-# INLINE pure #-} 118 SelectT gf <*> SelectT gx = SelectT $ \ k -> do 119 let h f = liftM f (gx (k . f)) 120 f <- gf ((>>= k) . h) 121 h f 122 {-# INLINE (<*>) #-} 123 m *> k = m >>= \_ -> k 124 {-# INLINE (*>) #-} 125 126instance (Functor m, MonadPlus m) => Alternative (SelectT r m) where 127 empty = mzero 128 {-# INLINE empty #-} 129 (<|>) = mplus 130 {-# INLINE (<|>) #-} 131 132instance (Monad m) => Monad (SelectT r m) where 133#if !(MIN_VERSION_base(4,8,0)) 134 return = lift . return 135 {-# INLINE return #-} 136#endif 137 SelectT g >>= f = SelectT $ \ k -> do 138 let h x = runSelectT (f x) k 139 y <- g ((>>= k) . h) 140 h y 141 {-# INLINE (>>=) #-} 142 143instance (Fail.MonadFail m) => Fail.MonadFail (SelectT r m) where 144 fail msg = lift (Fail.fail msg) 145 {-# INLINE fail #-} 146 147instance (MonadPlus m) => MonadPlus (SelectT r m) where 148 mzero = SelectT (const mzero) 149 {-# INLINE mzero #-} 150 SelectT f `mplus` SelectT g = SelectT $ \ k -> f k `mplus` g k 151 {-# INLINE mplus #-} 152 153instance MonadTrans (SelectT r) where 154 lift = SelectT . const 155 {-# INLINE lift #-} 156 157instance (MonadIO m) => MonadIO (SelectT r m) where 158 liftIO = lift . liftIO 159 {-# INLINE liftIO #-} 160 161#if !defined(HASKELL98) && __GLASGOW_HASKELL__ >= 708 162deriving instance Typeable SelectT 163#endif 164 165-- | Convert a selection computation to a continuation-passing computation. 166selectToContT :: (Monad m) => SelectT r m a -> ContT r m a 167selectToContT (SelectT g) = ContT $ \ k -> g k >>= k 168{-# INLINE selectToCont #-} 169 170-- | Deprecated name for 'selectToContT'. 171{-# DEPRECATED selectToCont "Use selectToContT instead" #-} 172selectToCont :: (Monad m) => SelectT r m a -> ContT r m a 173selectToCont = selectToContT 174