X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FIOEnv.hs;h=1f1dd8fec40b361a7e4e4db5a6bd3f48299b7804;hp=c72347eaab7d0cd0c1451400c3b1a453b705f692;hb=b2bd63f99d643f6b3eb30bb72bb9ae26d4183252;hpb=aba08f650f66a7979b7d8e513f8630663f33f4fb

diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index c72347e..1f1dd8f 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -3,73 +3,89 @@
 --
 -- The IO Monad with an environment
 --
+{-# LANGUAGE UndecidableInstances #-}
 
 module IOEnv (
-	IOEnv,	-- Instance of Monad
+        IOEnv, -- Instance of Monad
 
-	-- Standard combinators, specialised
-	returnM, thenM, thenM_, failM, failWithM,
-	mappM, mappM_, mapSndM, sequenceM, sequenceM_, 
-	foldlM, foldrM,
-	mapAndUnzipM, mapAndUnzip3M, 
-	checkM, ifM, zipWithM, zipWithM_,
+        -- Monad utilities
+        module MonadUtils,
 
-	-- Getting at the environment
-	getEnv, setEnv, updEnv,
+        -- Errors
+        failM, failWithM,
+        IOEnvFailure(..),
 
-	runIOEnv, unsafeInterleaveM,			
-	tryM, tryAllM, tryMostM, fixM, 
+        -- Getting at the environment
+        getEnv, setEnv, updEnv,
 
-	-- I/O operations
-	ioToIOEnv,
-	IORef, newMutVar, readMutVar, writeMutVar, updMutVar
-  ) where
-#include "HsVersions.h"
+        runIOEnv, unsafeInterleaveM,
+        tryM, tryAllM, tryMostM, fixM,
 
-import Panic		( try, tryUser, tryMost, Exception(..) )
+        -- I/O operations
+        IORef, newMutVar, readMutVar, writeMutVar, updMutVar,
+        atomicUpdMutVar, atomicUpdMutVar'
+  ) where
 
-import Data.IORef	( IORef, newIORef, readIORef, writeIORef )
-import System.IO.Unsafe	( unsafeInterleaveIO )
-import System.IO	( fixIO )
+import Exception
+import Panic
 
+import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef,
+                          atomicModifyIORef )
+import Data.Typeable
+import System.IO.Unsafe ( unsafeInterleaveIO )
+import System.IO        ( fixIO )
+import Control.Monad
+import MonadUtils
 
 ----------------------------------------------------------------------
---		Defining the monad type
+-- Defining the monad type
 ----------------------------------------------------------------------
 
 
 newtype IOEnv env a = IOEnv (env -> IO a)
+
+unIOEnv :: IOEnv env a -> (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 _ = 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))
+    fmap f (IOEnv m) = IOEnv (\ env -> fmap f (m env))
 
 returnM :: a -> IOEnv env a
-returnM a = IOEnv (\ env -> return a)
+returnM a = IOEnv (\ _ -> return a)
 
 thenM :: IOEnv env a -> (a -> IOEnv env b) -> IOEnv env b
 thenM (IOEnv m) f = IOEnv (\ env -> do { r <- m env ;
-				       unIOEnv (f r) env })
+                                         unIOEnv (f r) env })
 
 thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b
-thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env })
+thenM_ (IOEnv m) f = IOEnv (\ env -> do { _ <- m env ; unIOEnv f env })
 
 failM :: IOEnv env a
-failM = IOEnv (\ env -> ioError (userError "IOEnv failure"))
+failM = IOEnv (\ _ -> throwIO IOEnvFailure)
 
 failWithM :: String -> IOEnv env a
-failWithM s = IOEnv (\ env -> ioError (userError s))
+failWithM s = IOEnv (\ _ -> ioError (userError s))
+
+data IOEnvFailure = IOEnvFailure
+    deriving Typeable
 
+instance Show IOEnvFailure where
+    show IOEnvFailure = "IOEnv failure"
 
+instance Exception IOEnvFailure
 
 ----------------------------------------------------------------------
---	Fundmantal combinators specific to the monad
+-- Fundmantal combinators specific to the monad
 ----------------------------------------------------------------------
 
 
@@ -91,21 +107,27 @@ 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
+tryM :: IOEnv env r -> IOEnv env (Either IOEnvFailure r)
+-- 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 
+-- not be caught here, else they'll be reported as errors in the program
 -- begin compiled!
-tryM (IOEnv thing) = IOEnv (\ env -> tryUser (thing env))
+tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env))
 
-tryAllM :: IOEnv env r -> IOEnv env (Either Exception r)
+tryIOEnvFailure :: IO a -> IO (Either IOEnvFailure a)
+tryIOEnvFailure = try
+
+-- XXX We shouldn't be catching everything, e.g. timeouts
+tryAllM :: IOEnv env r -> IOEnv env (Either SomeException r)
 -- Catch *all* exceptions
 -- This is used when running a Template-Haskell splice, when
 -- even a pattern-match failure is a programmer error
 tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env))
 
-tryMostM :: IOEnv env r -> IOEnv env (Either Exception r)
+tryMostM :: IOEnv env r -> IOEnv env (Either SomeException r)
 tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env))
 
 ---------------------------
@@ -114,103 +136,81 @@ unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))
 
 
 ----------------------------------------------------------------------
---	Accessing input/output
+-- MonadPlus
+----------------------------------------------------------------------
+
+-- For use if the user has imported Control.Monad.Error from MTL
+-- Requires UndecidableInstances
+instance MonadPlus IO => MonadPlus (IOEnv env) where
+    mzero = IOEnv (const mzero)
+    m `mplus` n = IOEnv (\env -> unIOEnv m env `mplus` unIOEnv n env)
+
+----------------------------------------------------------------------
+-- Accessing input/output
 ----------------------------------------------------------------------
 
-ioToIOEnv :: IO a -> IOEnv env a
-ioToIOEnv io = IOEnv (\ env -> io)
+instance MonadIO (IOEnv env) where
+    liftIO io = IOEnv (\ _ -> 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 = liftIO (modifyIORef var upd)
 
-updMutVar :: IORef a -> (a->a) -> IOEnv env ()
-updMutVar var upd_fn = IOEnv (\ env -> do { v <- readIORef var; writeIORef var (upd_fn v) })
+-- | Atomically update the reference.  Does not force the evaluation of the
+-- new variable contents.  For strict update, use 'atomicUpdMutVar''.
+atomicUpdMutVar :: IORef a -> (a -> (a, b)) -> IOEnv env b
+atomicUpdMutVar var upd = liftIO (atomicModifyIORef var upd)
 
+-- | Strict variant of 'atomicUpdMutVar'.
+atomicUpdMutVar' :: IORef a -> (a -> (a, b)) -> IOEnv env b
+atomicUpdMutVar' var upd = do
+  r <- atomicUpdMutVar var upd
+  _ <- liftIO . evaluate =<< readMutVar var
+  return r
 
 ----------------------------------------------------------------------
---	Accessing the environment
+-- Accessing the environment
 ----------------------------------------------------------------------
 
 getEnv :: IOEnv env env
 {-# INLINE getEnv #-}
 getEnv = IOEnv (\ env -> return env)
 
+-- | Perform a computation with a different environment
 setEnv :: env' -> IOEnv env' a -> IOEnv env a
 {-# INLINE setEnv #-}
-setEnv new_env (IOEnv m) = IOEnv (\ env -> m new_env)
+setEnv new_env (IOEnv m) = IOEnv (\ _ -> m new_env)
 
+-- | Perform a computation with an altered environment
 updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a
 {-# INLINE updEnv #-}
 updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))
 
 
 ----------------------------------------------------------------------
---	Standard combinators, but specialised for this monad
---			(for efficiency)
+-- Standard combinators, but specialised for this monad
+-- (for efficiency)
 ----------------------------------------------------------------------
 
-mappM  	      :: (a -> IOEnv env b) -> [a] -> IOEnv env [b]
-mappM_ 	      :: (a -> IOEnv env b) -> [a] -> IOEnv env ()
-mapSndM       :: (b -> IOEnv env c) -> [(a,b)] -> IOEnv env [(a,c)]
-	-- Funny names to avoid clash with Prelude
-sequenceM     :: [IOEnv env a] -> IOEnv env [a]
-sequenceM_    :: [IOEnv env a] -> IOEnv env ()
-foldlM        :: (a -> b -> IOEnv env a)  -> a -> [b] -> IOEnv env a
-foldrM        :: (b -> a -> IOEnv env a)  -> a -> [b] -> IOEnv env a
-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
-
-mappM f []     = return []
-mappM f (x:xs) = do { r <- f x; rs <- mappM f xs; return (r:rs) }
-
-mapSndM f []     = return []
-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
-
-zipWithM :: (a -> b -> IOEnv env c) -> [a] -> [b] -> IOEnv env [c]
-zipWithM f [] bs = return []
-zipWithM f as [] = return []
-zipWithM f (a:as) (b:bs) = do { r <- f a b; rs <- zipWithM f as bs; return (r:rs) } 
-
-zipWithM_ :: (a -> b -> IOEnv env c) -> [a] -> [b] -> IOEnv env ()
-zipWithM_ f [] bs = return ()
-zipWithM_ f as [] = return ()
-zipWithM_ f (a:as) (b:bs) = do { f a b; zipWithM_ f as bs } 
-
-sequenceM [] = return []
-sequenceM (x:xs) = do { r <- x; rs <- sequenceM xs; return (r:rs) }
-
-sequenceM_ []     = return ()
-sequenceM_ (x:xs) = do { x; sequenceM_ xs }
-
-foldlM k z [] = return z
-foldlM k z (x:xs) = do { r <- k z x; foldlM k r xs }
-
-foldrM k z [] = return z
-foldrM k z (x:xs) = do { r <- foldrM k z xs; k x r }
-
-mapAndUnzipM f []     = return ([],[])
-mapAndUnzipM f (x:xs) = do { (r,s) <- f x; 
-			     (rs,ss) <- mapAndUnzipM f xs; 
-			     return (r:rs, s:ss) }
-
-mapAndUnzip3M f []     = return ([],[], [])
-mapAndUnzip3M f (x:xs) = do { (r,s,t) <- f x; 
-			      (rs,ss,ts) <- mapAndUnzip3M f xs; 
-			      return (r:rs, s:ss, t:ts) }
-
-checkM True  err = return ()
-checkM False err = do { err; return () }
-
-ifM True  do_it = do { do_it; return () }
-ifM False do_it = return ()
+-- {-# SPECIALIZE mapM          :: (a -> IOEnv env b) -> [a] -> IOEnv env [b] #-}
+-- {-# SPECIALIZE mapM_         :: (a -> IOEnv env b) -> [a] -> IOEnv env () #-}
+-- {-# SPECIALIZE mapSndM       :: (b -> IOEnv env c) -> [(a,b)] -> IOEnv env [(a,c)] #-}
+-- {-# SPECIALIZE sequence      :: [IOEnv env a] -> IOEnv env [a] #-}
+-- {-# SPECIALIZE sequence_     :: [IOEnv env a] -> IOEnv env () #-}
+-- {-# SPECIALIZE foldlM        :: (a -> b -> IOEnv env a)  -> a -> [b] -> IOEnv env a #-}
+-- {-# SPECIALIZE foldrM        :: (b -> a -> IOEnv env a)  -> a -> [b] -> IOEnv env a #-}
+-- {-# SPECIALIZE mapAndUnzipM  :: (a -> IOEnv env (b,c))   -> [a] -> IOEnv env ([b],[c]) #-}
+-- {-# SPECIALIZE mapAndUnzip3M :: (a -> IOEnv env (b,c,d)) -> [a] -> IOEnv env ([b],[c],[d]) #-}
+-- {-# SPECIALIZE zipWithM      :: (a -> b -> IOEnv env c) -> [a] -> [b] -> IOEnv env [c] #-}
+-- {-# SPECIALIZE zipWithM_     :: (a -> b -> IOEnv env c) -> [a] -> [b] -> IOEnv env () #-}
+-- {-# SPECIALIZE anyM          :: (a -> IOEnv env Bool) -> [a] -> IOEnv env Bool #-}
+-- {-# SPECIALIZE when          :: Bool -> IOEnv env a -> IOEnv env () #-}
+-- {-# SPECIALIZE unless        :: Bool -> IOEnv env a -> IOEnv env () #-}