MonadUtils.hs 7.2 KB
Newer Older
1
-- | Utilities related to Monad and Applicative classes
2
--   Mostly for backwards compatibility.
3 4 5 6

module MonadUtils
        ( Applicative(..)
        , (<$>)
7

8 9
        , MonadFix(..)
        , MonadIO(..)
10

11
        , liftIO1, liftIO2, liftIO3, liftIO4
12

13 14
        , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM
        , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M
15 16 17
        , mapAccumLM
        , mapSndM
        , concatMapM
18
        , mapMaybeM
19
        , fmapMaybeM, fmapEitherM
20
        , anyM, allM, orM
21
        , foldlM, foldlM_, foldrM
22
        , maybeMapM
23
        , whenM, unlessM
24
        , filterOutM
25 26
        ) where

27
-------------------------------------------------------------------------------
28
-- Imports
29
-------------------------------------------------------------------------------
30

31 32
import GhcPrelude

33 34
import Maybes

35
import Control.Applicative
36 37
import Control.Monad
import Control.Monad.Fix
38
import Control.Monad.IO.Class
39

40
-------------------------------------------------------------------------------
41 42
-- Lift combinators
--  These are used throughout the compiler
43
-------------------------------------------------------------------------------
44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60

-- | Lift an 'IO' operation with 1 argument into another monad
liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b
liftIO1 = (.) liftIO

-- | Lift an 'IO' operation with 2 arguments into another monad
liftIO2 :: MonadIO m => (a -> b -> IO c) -> a -> b -> m c
liftIO2 = ((.).(.)) liftIO

-- | Lift an 'IO' operation with 3 arguments into another monad
liftIO3 :: MonadIO m => (a -> b -> c -> IO d) -> a -> b -> c -> m d
liftIO3 = ((.).((.).(.))) liftIO

-- | Lift an 'IO' operation with 4 arguments into another monad
liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e
liftIO4 = (((.).(.)).((.).(.))) liftIO

61
-------------------------------------------------------------------------------
62
-- Common functions
63
--  These are used throughout the compiler
64
-------------------------------------------------------------------------------
65

66 67 68 69
zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M _ []     _      _      = return []
zipWith3M _ _      []     _      = return []
zipWith3M _ _      _      []     = return []
70
zipWith3M f (x:xs) (y:ys) (z:zs)
71 72 73 74 75
  = do { r  <- f x y z
       ; rs <- zipWith3M f xs ys zs
       ; return $ r:rs
       }

eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
76 77 78 79
zipWith3M_ :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m ()
zipWith3M_ f as bs cs = do { _ <- zipWith3M f as bs cs
                           ; return () }

80 81 82 83 84 85 86 87 88 89 90 91 92
zipWith4M :: Monad m => (a -> b -> c -> d -> m e)
          -> [a] -> [b] -> [c] -> [d] -> m [e]
zipWith4M _ []     _      _      _      = return []
zipWith4M _ _      []     _      _      = return []
zipWith4M _ _      _      []     _      = return []
zipWith4M _ _      _      _      []     = return []
zipWith4M f (x:xs) (y:ys) (z:zs) (a:as)
  = do { r  <- f x y z a
       ; rs <- zipWith4M f xs ys zs as
       ; return $ r:rs
       }


eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
93 94
zipWithAndUnzipM :: Monad m
                 => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])
95
{-# INLINABLE zipWithAndUnzipM #-}
96 97
-- See Note [flatten_many performance] in TcFlatten for why this
-- pragma is essential.
eir@cis.upenn.edu's avatar
eir@cis.upenn.edu committed
98 99 100 101 102 103
zipWithAndUnzipM f (x:xs) (y:ys)
  = do { (c, d) <- f x y
       ; (cs, ds) <- zipWithAndUnzipM f xs ys
       ; return (c:cs, d:ds) }
zipWithAndUnzipM _ _ _ = return ([], [])

104 105 106 107 108 109 110 111 112 113 114 115 116 117 118
-- | mapAndUnzipM for triples
mapAndUnzip3M :: Monad m => (a -> m (b,c,d)) -> [a] -> m ([b],[c],[d])
mapAndUnzip3M _ []     = return ([],[],[])
mapAndUnzip3M f (x:xs) = do
    (r1,  r2,  r3)  <- f x
    (rs1, rs2, rs3) <- mapAndUnzip3M f xs
    return (r1:rs1, r2:rs2, r3:rs3)

mapAndUnzip4M :: Monad m => (a -> m (b,c,d,e)) -> [a] -> m ([b],[c],[d],[e])
mapAndUnzip4M _ []     = return ([],[],[],[])
mapAndUnzip4M f (x:xs) = do
    (r1,  r2,  r3,  r4)  <- f x
    (rs1, rs2, rs3, rs4) <- mapAndUnzip4M f xs
    return (r1:rs1, r2:rs2, r3:rs3, r4:rs4)

119 120 121 122 123 124 125
mapAndUnzip5M :: Monad m => (a -> m (b,c,d,e,f)) -> [a] -> m ([b],[c],[d],[e],[f])
mapAndUnzip5M _ [] = return ([],[],[],[],[])
mapAndUnzip5M f (x:xs) = do
    (r1, r2, r3, r4, r5)      <- f x
    (rs1, rs2, rs3, rs4, rs5) <- mapAndUnzip5M f xs
    return (r1:rs1, r2:rs2, r3:rs3, r4:rs4, r5:rs5)

126 127
-- | Monadic version of mapAccumL
mapAccumLM :: Monad m
128
            => (acc -> x -> m (acc, y)) -- ^ combining function
129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
            -> acc                      -- ^ initial state
            -> [x]                      -- ^ inputs
            -> m (acc, [y])             -- ^ final state, outputs
mapAccumLM _ s []     = return (s, [])
mapAccumLM f s (x:xs) = do
    (s1, x')  <- f s x
    (s2, xs') <- mapAccumLM f s1 xs
    return    (s2, x' : xs')

-- | Monadic version of mapSnd
mapSndM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
mapSndM _ []         = return []
mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) }

-- | Monadic version of concatMap
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f xs = liftM concat (mapM f xs)

147 148 149 150
-- | Monadic version of mapMaybe
mapMaybeM :: (Monad m) => (a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM f = liftM catMaybes . mapM f

151 152 153 154 155 156 157 158 159 160
-- | Monadic version of fmap
fmapMaybeM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)
fmapMaybeM _ Nothing  = return Nothing
fmapMaybeM f (Just x) = f x >>= (return . Just)

-- | Monadic version of fmap
fmapEitherM :: Monad m => (a -> m b) -> (c -> m d) -> Either a c -> m (Either b d)
fmapEitherM fl _ (Left  a) = fl a >>= (return . Left)
fmapEitherM _ fr (Right b) = fr b >>= (return . Right)

batterseapower's avatar
batterseapower committed
161
-- | Monadic version of 'any', aborts the computation at the first @True@ value
162 163 164
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM _ []     = return False
anyM f (x:xs) = do b <- f x
165
                   if b then return True
166 167
                        else anyM f xs

batterseapower's avatar
batterseapower committed
168 169 170 171 172
-- | Monad version of 'all', aborts the computation at the first @False@ value
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM _ []     = return True
allM f (b:bs) = (f b) >>= (\bv -> if bv then allM f bs else return False)

173 174 175 176
-- | Monadic version of or
orM :: Monad m => m Bool -> m Bool -> m Bool
orM m1 m2 = m1 >>= \x -> if x then return True else m2

177 178 179 180
-- | Monadic version of foldl
foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldlM = foldM

181 182 183 184
-- | Monadic version of foldl that discards its result
foldlM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()
foldlM_ = foldM_

185 186 187
-- | Monadic version of foldr
foldrM        :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a
foldrM _ z []     = return z
Simon Marlow's avatar
Simon Marlow committed
188
foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }
189 190 191 192 193

-- | Monadic version of fmap specialised for Maybe
maybeMapM :: Monad m => (a -> m b) -> (Maybe a -> m (Maybe b))
maybeMapM _ Nothing  = return Nothing
maybeMapM m (Just x) = liftM Just $ m x
194 195 196 197 198

-- | Monadic version of @when@, taking the condition in the monad
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb thing = do { b <- mb
                    ; when b thing }
199 200 201 202 203

-- | Monadic version of @unless@, taking the condition in the monad
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM condM acc = do { cond <- condM
                       ; unless cond acc }
204 205 206 207 208

-- | Like 'filterM', only it reverses the sense of the test.
filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a]
filterOutM p =
  foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure [])