MonadUtils.hs 4.14 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15

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

module MonadUtils
        ( Applicative(..)
        , (<$>)
        
        , MonadFix(..)
        , MonadIO(..)
        
        , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M
        , mapAccumLM
        , mapSndM
        , concatMapM
batterseapower's avatar
batterseapower committed
16
        , anyM, allM
17 18 19 20 21 22 23
        , foldlM, foldrM
        ) where

----------------------------------------------------------------------------------------
-- Detection of available libraries
----------------------------------------------------------------------------------------

Simon Marlow's avatar
Simon Marlow committed
24
#if __GLASGOW_HASKELL__ >= 606
25
#define HAVE_APPLICATIVE 1
Simon Marlow's avatar
Simon Marlow committed
26 27 28
#else
#define HAVE_APPLICATIVE 0
#endif
29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
-- we don't depend on MTL for now
#define HAVE_MTL 0

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

#if HAVE_APPLICATIVE
import Control.Applicative
#endif
#if HAVE_MTL
import Control.Monad.Trans
#endif
import Control.Monad
import Control.Monad.Fix

----------------------------------------------------------------------------------------
-- Applicative
----------------------------------------------------------------------------------------

#if !HAVE_APPLICATIVE

class Functor f => Applicative f where
    pure  :: a -> f a
    (<*>) :: f (a -> b) -> f a -> f b

(<$>) :: Functor f => (a -> b) -> (f a -> f b)
(<$>) = fmap

infixl 4 <$>
infixl 4 <*>

Simon Marlow's avatar
Simon Marlow committed
61 62 63 64
instance Applicative IO where
	pure = return
	(<*>) = ap

65 66 67 68 69 70 71 72 73 74 75
#endif

----------------------------------------------------------------------------------------
-- MTL
----------------------------------------------------------------------------------------

#if !HAVE_MTL

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

76
instance MonadIO IO where liftIO = id
77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119
#endif

----------------------------------------------------------------------------------------
-- Common functions
--  These are used throught the compiler
----------------------------------------------------------------------------------------

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

batterseapower's avatar
batterseapower committed
120
-- | Monadic version of 'any', aborts the computation at the first @True@ value
121 122 123 124 125 126
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
127 128 129 130 131
-- | 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)

132 133 134 135 136 137 138 139
-- | Monadic version of foldl
foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
foldlM = foldM

-- | Monadic version of foldr
foldrM        :: (Monad m) => (b -> a -> m a) -> a -> [b] -> m a
foldrM _ z []     = return z
foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }