Monads.hs 4.05 KB
Newer Older
1
2
module System.Console.Haskeline.Monads(
                module System.Console.Haskeline.MonadException,
3
4
                MonadTrans(..),
                MonadIO(..),
5
6
                ReaderT,
                runReaderT,
7
                runReaderT',
judah's avatar
judah committed
8
                mapReaderT,
9
                asks,
10
11
                StateT,
                runStateT,
12
                evalStateT',
judah's avatar
judah committed
13
                mapStateT,
judah's avatar
judah committed
14
                gets,
15
16
17
                modify,
                update,
                MonadReader(..),
18
                MonadState(..),
19
20
                MaybeT(MaybeT),
                runMaybeT,
21
                orElse
22
23
                ) where

24
25
import Control.Applicative (Applicative(..))
import Control.Monad (ap, liftM)
26
27
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Class (MonadTrans(..))
28
import Control.Monad.Trans.Maybe (MaybeT(MaybeT),runMaybeT)
29
30
import Control.Monad.Trans.Reader hiding (ask,asks)
import qualified Control.Monad.Trans.Reader as Reader
31
import Data.IORef
judah's avatar
judah committed
32
#if __GLASGOW_HASKELL__ < 705
33
import Prelude hiding (catch)
judah's avatar
judah committed
34
#endif
35

36
import System.Console.Haskeline.MonadException
37
38
39
40

class Monad m => MonadReader r m where
    ask :: m r

41
42
43
instance Monad m => MonadReader r (ReaderT r m) where
    ask = Reader.ask

judah's avatar
judah committed
44
45
46
47
instance Monad m => MonadReader s (StateT s m) where
    ask = get

instance (MonadReader r m, MonadTrans t, Monad (t m)) => MonadReader r (t m) where
48
49
    ask = lift ask

50
51
52
53
54
55
56
asks :: MonadReader r m => (r -> a) -> m a
asks f = liftM f ask

class Monad m => MonadState s m where
    get :: m s
    put :: s -> m ()

judah's avatar
judah committed
57
58
gets :: MonadState s m => (s -> a) -> m a
gets f = liftM f get
59

60
61
62
63
64
65
66
67
68
69
modify :: MonadState s m => (s -> s) -> m ()
modify f = get >>= put . f

update :: MonadState s m => (s -> (a,s)) -> m a
update f = do
    s <- get
    let (x,s') = f s
    put s'
    return x

70
71
runReaderT' :: Monad m => r -> ReaderT r m a -> m a
runReaderT' = flip runReaderT
72

73
74
75
newtype StateT s m a = StateT { getStateTFunc 
                                    :: forall r . s -> m ((a -> s -> r) -> r)}

76
77
78
79
instance Monad m => Functor (StateT s m) where
    fmap  = liftM

instance Monad m => Applicative (StateT s m) where
80
    pure x = StateT $ \s -> return $ \f -> f x s
81
82
    (<*>) = ap

83
instance Monad m => Monad (StateT s m) where
84
    return = pure
85
86
87
88
89
90
91
92
93
94
95
96
    StateT f >>= g = StateT $ \s -> do
        useX <- f s
        useX $ \x s' -> getStateTFunc (g x) s'

instance MonadTrans (StateT s) where
    lift m = StateT $ \s -> do
        x <- m
        return $ \f -> f x s

instance MonadIO m => MonadIO (StateT s m) where
    liftIO = lift . liftIO

judah's avatar
judah committed
97
98
99
mapStateT :: (forall b . m b -> n b) -> StateT s m a -> StateT s n a
mapStateT f (StateT m) = StateT (\s -> f (m s))

100
101
102
103
104
runStateT :: Monad m => StateT s m a -> s -> m (a, s)
runStateT f s = do
    useXS <- getStateTFunc f s
    return $ useXS $ \x s' -> (x,s')

105
106
107
108
109
makeStateT :: Monad m => (s -> m (a,s)) -> StateT s m a
makeStateT f = StateT $ \s -> do
                            (x,s') <- f s
                            return $ \g -> g x s'

110
111
112
113
114
115
116
117
instance Monad m => MonadState s (StateT s m) where
    get = StateT $ \s -> return $ \f -> f s s
    put s = s `seq` StateT $ \_ -> return $ \f -> f () s

instance (MonadState s m, MonadTrans t, Monad (t m)) => MonadState s (t m) where
    get = lift get
    put = lift . put

118
119
120
121
122
123
-- ReaderT (IORef s) is better than StateT s for some applications,
-- since StateT loses its state after an exception such as ctrl-c.
instance MonadIO m => MonadState s (ReaderT (IORef s) m) where
    get = ask >>= liftIO . readIORef
    put s = ask >>= liftIO . flip writeIORef s

124
evalStateT' :: Monad m => s -> StateT s m a -> m a
125
126
127
evalStateT' s f = liftM fst $ runStateT f s

instance MonadException m => MonadException (StateT s m) where
128
129
130
131
132
133
    controlIO f = makeStateT $ \s -> controlIO $ \run ->
                    fmap (flip runStateT s) $ f $ stateRunIO s run
      where
        stateRunIO :: s -> RunIO m -> RunIO (StateT s m)
        stateRunIO s (RunIO run) = RunIO (\m -> fmap (makeStateT . const)
                                        $ run (runStateT m s))
134
135
136

orElse :: Monad m => MaybeT m a -> m a -> m a
orElse (MaybeT f) g = f >>= maybe g return