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

diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs
index f373e59..305e30e 100644
--- a/compiler/utils/IOEnv.hs
+++ b/compiler/utils/IOEnv.hs
@@ -1,15 +1,9 @@
-{-# 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
 --
 -- The IO Monad with an environment
 --
+{-# LANGUAGE UndecidableInstances #-}
 
 module IOEnv (
         IOEnv, -- Instance of Monad
@@ -19,6 +13,7 @@ module IOEnv (
 
         -- Errors
         failM, failWithM,
+        IOEnvFailure(..),
 
         -- Getting at the environment
         getEnv, setEnv, updEnv,
@@ -29,13 +24,15 @@ module IOEnv (
         -- I/O operations
         IORef, newMutVar, readMutVar, writeMutVar, updMutVar
   ) where
-#include "HsVersions.h"
 
-import Panic            ( try, tryUser, tryMost, Exception(..) )
+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
 
 ----------------------------------------------------------------------
@@ -44,13 +41,15 @@ import MonadUtils
 
 
 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
+    fail _ = failM -- Ignore the string
 
 instance Applicative (IOEnv m) where
     pure = returnM
@@ -60,7 +59,7 @@ 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)
+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 ;
@@ -70,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 (\ 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
@@ -100,7 +105,7 @@ fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))
 
 
 ---------------------------
-tryM :: IOEnv env r -> IOEnv env (Either Exception r)
+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
 --
@@ -108,15 +113,19 @@ tryM :: IOEnv env r -> IOEnv env (Either Exception 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
 
-tryAllM :: IOEnv env r -> IOEnv env (Either Exception r)
+-- 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))
 
 ---------------------------
@@ -125,11 +134,21 @@ 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
 ----------------------------------------------------------------------
 
 instance MonadIO (IOEnv env) where
-    liftIO io = IOEnv (\ env -> io)
+    liftIO io = IOEnv (\ _ -> io)
 
 newMutVar :: a -> IOEnv env (IORef a)
 newMutVar val = liftIO (newIORef val)
@@ -155,7 +174,7 @@ 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
@@ -168,17 +187,17 @@ updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))
 -- (for efficiency)
 ----------------------------------------------------------------------
 
-{-# -- 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 () #-}
+-- {-# 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 () #-}