From acb70e7c53a81ffea471d3bd6fb75c12e6bb2a37 Mon Sep 17 00:00:00 2001
From: Twan van Laarhoven <twanvl@gmail.com>
Date: Thu, 17 Jan 2008 16:19:39 +0000
Subject: [PATCH] Add 'util/MonadUtils.hs' with common monad (and applicative)
 combinators

---
 compiler/utils/MonadUtils.hs |  125 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 125 insertions(+)
 create mode 100644 compiler/utils/MonadUtils.hs

diff --git a/compiler/utils/MonadUtils.hs b/compiler/utils/MonadUtils.hs
new file mode 100644
index 0000000..edce995
--- /dev/null
+++ b/compiler/utils/MonadUtils.hs
@@ -0,0 +1,125 @@
+
+-- | Utilities related to Monad and Applicative classes
+--   Mostly for backwards compatability.
+
+module MonadUtils
+        ( Applicative(..)
+        , (<$>)
+        
+        , MonadFix(..)
+        , MonadIO(..)
+        
+        , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M
+        , mapAccumLM
+        , mapSndM
+        , concatMapM
+        , anyM
+        , foldlM, foldrM
+        ) where
+
+----------------------------------------------------------------------------------------
+-- Detection of available libraries
+----------------------------------------------------------------------------------------
+
+#define HAVE_APPLICATIVE 1
+-- 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 <*>
+
+#endif
+
+----------------------------------------------------------------------------------------
+-- MTL
+----------------------------------------------------------------------------------------
+
+#if !HAVE_MTL
+
+class Monad m => MonadIO m where
+    liftIO :: IO a -> m a
+
+#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)
+
+-- | Monadic version of 'any', aborts the computation at the first False 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
+
+-- | 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 }
-- 
1.7.10.4