Replace remaining uses of ioToIOEnv by liftIO, remove ioToIOEnv

[ghc-hetmet.git] / compiler / utils / IOEnv.hs

diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index c0277ae..224147f 100644 (file)
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -1,3 +1,10 @@
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
 --
 -- (c) The University of Glasgow 2002-2006
 --
@@ -10,7 +17,7 @@ module IOEnv (
        -- Standard combinators, specialised
        returnM, thenM, thenM_, failM, failWithM,
        mappM, mappM_, mapSndM, sequenceM, sequenceM_, 
-       foldlM, foldrM,
+       foldlM, foldrM, anyM,
        mapAndUnzipM, mapAndUnzip3M, 
        checkM, ifM, zipWithM, zipWithM_,
 
@@ -21,17 +28,16 @@ module IOEnv (
        tryM, tryAllM, tryMostM, fixM, 
 
        -- I/O operations
-       ioToIOEnv,
        IORef, newMutVar, readMutVar, writeMutVar, updMutVar
   ) where
 #include "HsVersions.h"
 
 import Panic           ( try, tryUser, tryMost, Exception(..) )
 
-import Data.IORef      ( IORef, newIORef, readIORef, writeIORef )
+import Data.IORef      ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
 import System.IO.Unsafe        ( unsafeInterleaveIO )
 import System.IO       ( fixIO )
-
+import MonadUtils
 
 ----------------------------------------------------------------------
 --             Defining the monad type
@@ -42,10 +48,17 @@ newtype IOEnv env a = IOEnv (env -> IO a)
 unIOEnv (IOEnv m) = m
 
 instance Monad (IOEnv m) where
-  (>>=)  = thenM
-  (>>)   = thenM_
-  return = returnM
-  fail s = failM       -- Ignore the string
+    (>>=)  = thenM
+    (>>)   = thenM_
+    return = returnM
+    fail s = failM     -- Ignore the string
+
+instance Applicative (IOEnv m) where
+    pure = returnM
+    IOEnv f <*> IOEnv x = IOEnv (\ env -> f env <*> x env )
+
+instance Functor (IOEnv m) where
+    fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env))
 
 returnM :: a -> IOEnv env a
 returnM a = IOEnv (\ env -> return a)
@@ -89,7 +102,9 @@ fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))
 
 ---------------------------
 tryM :: IOEnv env r -> IOEnv env (Either Exception r)
--- Reflect UserError exceptions into IOEnv monad
+-- Reflect UserError exceptions (only) into IOEnv monad
+-- Other exceptions are not caught; they are simply propagated as exns
+--
 -- The idea is that errors in the program being compiled will give rise
 -- to UserErrors.  But, say, pattern-match failures in GHC itself should
 -- not be caught here, else they'll be reported as errors in the program 
@@ -114,20 +129,20 @@ unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))
 --     Accessing input/output
 ----------------------------------------------------------------------
 
-ioToIOEnv :: IO a -> IOEnv env a
-ioToIOEnv io = IOEnv (\ env -> io)
+instance MonadIO (IOEnv env) where
+    liftIO io = IOEnv (\ env -> io)
 
 newMutVar :: a -> IOEnv env (IORef a)
-newMutVar val = IOEnv (\ env -> newIORef val)
+newMutVar val = liftIO (newIORef val)
 
 writeMutVar :: IORef a -> a -> IOEnv env ()
-writeMutVar var val = IOEnv (\ env -> writeIORef var val)
+writeMutVar var val = liftIO (writeIORef var val)
 
 readMutVar :: IORef a -> IOEnv env a
-readMutVar var = IOEnv (\ env -> readIORef var)
+readMutVar var = liftIO (readIORef var)
 
-updMutVar :: IORef a -> (a->a) -> IOEnv env ()
-updMutVar var upd_fn = IOEnv (\ env -> do { v <- readIORef var; writeIORef var (upd_fn v) })
+updMutVar :: IORef a -> (a -> a) -> IOEnv env ()
+updMutVar var upd = liftIO (modifyIORef var upd)
 
 
 ----------------------------------------------------------------------
@@ -164,6 +179,7 @@ mapAndUnzipM  :: (a -> IOEnv env (b,c))   -> [a] -> IOEnv env ([b],[c])
 mapAndUnzip3M :: (a -> IOEnv env (b,c,d)) -> [a] -> IOEnv env ([b],[c],[d])
 checkM       :: Bool -> IOEnv env a -> IOEnv env ()    -- Perform arg if bool is False
 ifM          :: Bool -> IOEnv env a -> IOEnv env ()    -- Perform arg if bool is True
+anyM         :: (a -> IOEnv env Bool) -> [a] -> IOEnv env Bool
 
 mappM f []     = return []
 mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) }
@@ -174,6 +190,10 @@ mapSndM f ((a,b):xs) = do { c <- f b; rs <- mapSndM f xs; return ((a,c):rs) }
 mappM_ f []     = return ()
 mappM_ f (x:xs) = f x >> mappM_ f xs
 
+anyM f [] = return False
+anyM f (x:xs) = do { b <- f x; if b then return True 
+                                   else anyM f xs }
+
 zipWithM :: (a -> b -> IOEnv env c) -> [a] -> [b] -> IOEnv env [c]
 zipWithM f [] bs = return []
 zipWithM f as [] = return []