X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Futils%2FIOEnv.hs;h=305e30eed7fded9287b8d1ebaef3811ca9b7d215;hp=394a1c8f451f81745e441cea0bb6c53a17c04394;hb=9bcd95bad83ee937c178970e8b729732e680fe1e;hpb=ec197dfef33654dd16b5832905dad2e52f79f7ab

diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index 394a1c8..305e30e 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -3,6 +3,7 @@
 --
 -- The IO Monad with an environment
 --
+{-# LANGUAGE UndecidableInstances #-}
 
 module IOEnv (
         IOEnv, -- Instance of Monad
@@ -12,6 +13,7 @@ module IOEnv (
 
         -- Errors
         failM, failWithM,
+        IOEnvFailure(..),
 
         -- Getting at the environment
         getEnv, setEnv, updEnv,
@@ -27,8 +29,10 @@ import Exception
 import Panic
 
 import Data.IORef       ( IORef, newIORef, readIORef, writeIORef, modifyIORef )
+import Data.Typeable
 import System.IO.Unsafe ( unsafeInterleaveIO )
 import System.IO        ( fixIO )
+import Control.Monad
 import MonadUtils
 
 ----------------------------------------------------------------------
@@ -65,12 +69,18 @@ thenM_ :: IOEnv env a -> IOEnv env b -> IOEnv env b
 thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env })
 
 failM :: IOEnv env a
-failM = IOEnv (\ _ -> ioError (userError "IOEnv failure"))
+failM = IOEnv (\ _ -> throwIO IOEnvFailure)
 
 failWithM :: String -> IOEnv env a
 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
@@ -95,11 +105,7 @@ fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))
 
 
 ---------------------------
-#if __GLASGOW_HASKELL__ < 609
-tryM :: IOEnv env r -> IOEnv env (Either Exception r)
-#else
-tryM :: IOEnv env r -> IOEnv env (Either IOException r)
-#endif
+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
 --
@@ -107,7 +113,10 @@ tryM :: IOEnv env r -> IOEnv env (Either IOException r)
 -- 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
 -- begin compiled!
-tryM (IOEnv thing) = IOEnv (\ env -> tryUser (thing env))
+tryM (IOEnv thing) = IOEnv (\ env -> tryIOEnvFailure (thing env))
+
+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)
@@ -125,6 +134,16 @@ unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env))
 
 
 ----------------------------------------------------------------------
+-- 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
 ----------------------------------------------------------------------