[project @ 2005-05-20 11:42:57 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcRnMonad.lhs

diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index 306a71b..1023f56 100644 (file)
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -491,68 +491,88 @@ discardWarnings thing_inside
 
 
 \begin{code}
+try_m :: TcRn r -> TcRn (Either Exception r)
+-- Does try_m, with a debug-trace on failure
+try_m thing 
+  = do { mb_r <- tryM thing ;
+        case mb_r of 
+            Left exn -> do { traceTc (exn_msg exn); return mb_r }
+            Right r  -> return mb_r }
+  where
+    exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
+
+-----------------------
 recoverM :: TcRn r     -- Recovery action; do this if the main one fails
         -> TcRn r      -- Main action: do this first
         -> TcRn r
+-- Errors in 'thing' are retained
 recoverM recover thing 
   = do { mb_res <- try_m thing ;
         case mb_res of
           Left exn  -> recover
           Right res -> returnM res }
 
+-----------------------
 tryTc :: TcRn a -> TcRn (Messages, Maybe a)
-    -- (tryTc m) executes m, and returns
-    -- Just r,  if m succeeds (returning r) and caused no errors
-    -- Nothing, if m fails, or caused errors
-    -- It also returns all the errors accumulated by m
-    --         (even in the Just case, there might be warnings)
-    --
-    -- It always succeeds (never raises an exception)
+-- (tryTc m) executes m, and returns
+--     Just r,  if m succeeds (returning r)
+--     Nothing, if m fails
+-- It also returns all the errors and warnings accumulated by m
+-- It always succeeds (never raises an exception)
 tryTc m 
  = do {        errs_var <- newMutVar emptyMessages ;
-       
-       mb_r <- try_m (setErrsVar errs_var m) ; 
-
-       new_errs <- readMutVar errs_var ;
-
-       dflags <- getDOpts ;
-
-       return (new_errs, 
-               case mb_r of
-                 Left exn -> Nothing
-                 Right r | errorsFound dflags new_errs -> Nothing
-                         | otherwise                   -> Just r) 
+       res  <- try_m (setErrsVar errs_var m) ; 
+       msgs <- readMutVar errs_var ;
+       return (msgs, case res of
+                           Left exn  -> Nothing
+                           Right val -> Just val)
+       -- The exception is always the IOEnv built-in
+       -- in exception; see IOEnv.failM
    }
 
-try_m :: TcRn r -> TcRn (Either Exception r)
--- Does try_m, with a debug-trace on failure
-try_m thing 
-  = do { mb_r <- tryM thing ;
-        case mb_r of 
-            Left exn -> do { traceTc (exn_msg exn); return mb_r }
-            Right r  -> return mb_r }
-  where
-    exn_msg exn = text "tryTc/recoverM recovering from" <+> text (showException exn)
+-----------------------
+tryTcErrs :: TcRn a -> TcRn (Messages, Maybe a)
+-- Run the thing, returning 
+--     Just r,  if m succceeds with no error messages
+--     Nothing, if m fails, or if it succeeds but has error messages
+-- Either way, the messages are returned; even in the Just case
+-- there might be warnings
+tryTcErrs thing 
+  = do  { (msgs, res) <- tryTc thing
+       ; dflags <- getDOpts
+       ; let errs_found = errorsFound dflags msgs
+       ; return (msgs, case res of
+                         Nothing -> Nothing
+                         Just val | errs_found -> Nothing
+                                  | otherwise  -> Just val)
+       }
 
+-----------------------
 tryTcLIE :: TcM a -> TcM (Messages, Maybe a)
--- Just like tryTc, except that it ensures that the LIE
+-- Just like tryTcErrs, except that it ensures that the LIE
 -- for the thing is propagated only if there are no errors
 -- Hence it's restricted to the type-check monad
 tryTcLIE thing_inside
-  = do { ((errs, mb_r), lie) <- getLIE (tryTc thing_inside) ;
-        ifM (isJust mb_r) (extendLIEs lie) ;
-        return (errs, mb_r) }
+  = do  { ((msgs, mb_res), lie) <- getLIE (tryTcErrs thing_inside) ;
+       ; case mb_res of
+           Nothing  -> return (msgs, Nothing)
+           Just val -> do { extendLIEs lie; return (msgs, Just val) }
+       }
 
+-----------------------
 tryTcLIE_ :: TcM r -> TcM r -> TcM r
--- (tryTcLIE_ r m) tries m; if it succeeds it returns it,
--- otherwise it returns r.  Any error messages added by m are discarded,
--- whether or not m succeeds.
+-- (tryTcLIE_ r m) tries m; 
+--     if m succeeds with no error messages, it's the answer
+--     otherwise tryTcLIE_ drops everything from m and tries r instead.
 tryTcLIE_ recover main
-  = do { (_msgs, mb_res) <- tryTcLIE main ;
-        case mb_res of
-          Just res -> return res
-          Nothing  -> recover }
+  = do { (msgs, mb_res) <- tryTcLIE main
+       ; case mb_res of
+            Just val -> do { addMessages msgs  -- There might be warnings
+                            ; return val }
+            Nothing  -> recover                -- Discard all msgs
+       }
 
+-----------------------
 checkNoErrs :: TcM r -> TcM r
 -- (checkNoErrs m) succeeds iff m succeeds and generates no errors
 -- If m fails then (checkNoErrsTc m) fails.
@@ -561,12 +581,12 @@ checkNoErrs :: TcM r -> TcM r
 --     If so, it fails too.
 -- Regardless, any errors generated by m are propagated to the enclosing context.
 checkNoErrs main
-  = do { (msgs, mb_res) <- tryTcLIE main ;
-        addMessages msgs ;
-        case mb_res of
-          Just r  -> return r
-          Nothing -> failM
-   }
+  = do { (msgs, mb_res) <- tryTcLIE main
+       ; addMessages msgs
+       ; case mb_res of
+           Nothing   -> failM
+           Just val -> return val
+       } 
 
 ifErrsM :: TcRn r -> TcRn r -> TcRn r
 --     ifErrsM bale_out main