MonadUtils.hs 5.72 KB
Newer Older
1 2 3 4 5 6 7 8 9 10

-- | Utilities related to Monad and Applicative classes
--   Mostly for backwards compatability.

module MonadUtils
        ( Applicative(..)
        , (<$>)
        
        , MonadFix(..)
        , MonadIO(..)
11 12
	
  	, ID, runID
13
        
14
        , liftIO1, liftIO2, liftIO3, liftIO4
15 16

        , zipWith3M        
17 18 19 20
        , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M
        , mapAccumLM
        , mapSndM
        , concatMapM
21
        , mapMaybeM
batterseapower's avatar
batterseapower committed
22
        , anyM, allM
23
        , foldlM, foldlM_, foldrM
24
        , maybeMapM
25 26
        ) where

27 28
import Outputable 

29 30 31 32 33 34 35 36 37 38 39
----------------------------------------------------------------------------------------
-- Detection of available libraries
----------------------------------------------------------------------------------------

-- we don't depend on MTL for now
#define HAVE_MTL 0

----------------------------------------------------------------------------------------
-- Imports
----------------------------------------------------------------------------------------

40 41
import Maybes

42 43 44 45 46 47 48
import Control.Applicative
#if HAVE_MTL
import Control.Monad.Trans
#endif
import Control.Monad
import Control.Monad.Fix

49 50 51 52 53 54 55 56 57 58 59 60 61 62
----------------------------------------------------------------------------------------
-- The ID monad
----------------------------------------------------------------------------------------

newtype ID a = ID a
instance Monad ID where
  return x     = ID x
  (ID x) >>= f = f x
  _ >> y       = y
  fail s       = panic s

runID :: ID a -> a
runID (ID x) = x

63 64 65 66 67 68 69 70 71
----------------------------------------------------------------------------------------
-- MTL
----------------------------------------------------------------------------------------

#if !HAVE_MTL

class Monad m => MonadIO m where
    liftIO :: IO a -> m a

72
instance MonadIO IO where liftIO = id
73 74
#endif

75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
----------------------------------------------------------------------------------------
-- Lift combinators
--  These are used throughout the compiler
----------------------------------------------------------------------------------------

-- | 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

96 97
----------------------------------------------------------------------------------------
-- Common functions
98
--  These are used throughout the compiler
99 100
----------------------------------------------------------------------------------------

101 102 103 104 105 106 107 108 109 110
zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d]
zipWith3M _ []     _      _      = return []
zipWith3M _ _      []     _      = return []
zipWith3M _ _      _      []     = return []
zipWith3M f (x:xs) (y:ys) (z:zs) 
  = do { r  <- f x y z
       ; rs <- zipWith3M f xs ys zs
       ; return $ r:rs
       }

111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146
-- | 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)

-- | Monadic version of mapAccumL
mapAccumLM :: Monad m
            => (acc -> x -> m (acc, y)) -- ^ combining funcction
            -> 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

batterseapower's avatar
batterseapower committed
151
-- | Monadic version of 'any', aborts the computation at the first @True@ value
152 153 154 155 156 157
anyM :: Monad m => (a -> m Bool) -> [a] -> m Bool
anyM _ []     = return False
anyM f (x:xs) = do b <- f x
                   if b then return True 
                        else anyM f xs

batterseapower's avatar
batterseapower committed
158 159 160 161 162
-- | 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)

163 164 165 166
-- | Monadic version of foldl
foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldlM = foldM

167 168 169 170
-- | Monadic version of foldl that discards its result
foldlM_ :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m ()
foldlM_ = foldM_

171 172 173
-- | 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
174
foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }
175 176 177 178 179

-- | 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