X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Futils%2FMonadUtils.hs;h=85d864231363c3e3ccd3dbc553922d0355731b5f;hb=af37b3001b086f39cbf1fe3ea2aa5c37f4f9a34f;hp=edce9957867dae5d2bff79aeb6618d06669f0b32;hpb=acb70e7c53a81ffea471d3bd6fb75c12e6bb2a37;p=ghc-hetmet.git

diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs
index edce995..85d8642 100644
--- a/compiler/utils/MonadUtils.hs
+++ b/compiler/utils/MonadUtils.hs
@@ -13,7 +13,7 @@ module MonadUtils
         , mapAccumLM
         , mapSndM
         , concatMapM
-        , anyM
+        , anyM, allM
         , foldlM, foldrM
         ) where
 
@@ -21,7 +21,11 @@ module MonadUtils
 -- Detection of available libraries
 ----------------------------------------------------------------------------------------
 
+#if __GLASGOW_HASKELL__ >= 606
 #define HAVE_APPLICATIVE 1
+#else
+#define HAVE_APPLICATIVE 0
+#endif
 -- we don't depend on MTL for now
 #define HAVE_MTL 0
 
@@ -54,6 +58,10 @@ class Functor f => Applicative f where
 infixl 4 <$>
 infixl 4 <*>
 
+instance Applicative IO where
+	pure = return
+	(<*>) = ap
+
 #endif
 
 ----------------------------------------------------------------------------------------
@@ -65,6 +73,7 @@ infixl 4 <*>
 class Monad m => MonadIO m where
     liftIO :: IO a -> m a
 
+instance MonadIO IO where liftIO = id
 #endif
 
 ----------------------------------------------------------------------------------------
@@ -108,13 +117,18 @@ mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) }
 concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
 concatMapM f xs = liftM concat (mapM f xs)
 
--- | Monadic version of 'any', aborts the computation at the first False value
+-- | Monadic version of 'any', aborts the computation at the first @True@ value
 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
 
+-- | 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)
+
 -- | Monadic version of foldl
 foldlM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
 foldlM = foldM