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