X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcMonad.lhs;h=8b484a3fafce66682e40f0f90198bb25bcba784f;hb=cc3d91e372a0bdc6e74a0e2a1fb1b27df3c636f0;hp=c0fb587abb18ac29b773aca5589f3e1de168cd3b;hpb=6246213687602d5bd9b4f12026fd300dfa4b4afd;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs
index c0fb587..8b484a3 100644
--- a/ghc/compiler/typecheck/TcMonad.lhs
+++ b/ghc/compiler/typecheck/TcMonad.lhs
@@ -1,9 +1,7 @@
 \begin{code}
 module TcMonad(
-	TcType, 
-	TcTauType, TcPredType, TcThetaType, TcRhoType,
-	TcTyVar, TcTyVarSet,
-	TcKind,
+	TcType, TcTauType, TcPredType, TcThetaType, TcRhoType,
+	TcTyVar, TcTyVarSet, TcKind,
 
 	TcM, NF_TcM, TcDown, TcEnv, 
 
@@ -32,7 +30,7 @@ module TcMonad(
 
 	tcAddSrcLoc, tcGetSrcLoc, tcGetInstLoc,
 	tcAddErrCtxtM, tcSetErrCtxtM,
-	tcAddErrCtxt, tcSetErrCtxt,
+	tcAddErrCtxt, tcSetErrCtxt, tcPopErrCtxt,
 
 	tcNewMutVar, tcNewSigTyVar, tcReadMutVar, tcWriteMutVar, TcRef,
 	tcNewMutTyVar, tcReadMutTyVar, tcWriteMutTyVar,
@@ -47,10 +45,9 @@ module TcMonad(
 
 import {-# SOURCE #-} TcEnv  ( TcEnv )
 
-import HsSyn		( HsOverLit )
+import HsLit		( HsOverLit )
 import RnHsSyn		( RenamedPat, RenamedArithSeqInfo, RenamedHsExpr )
-import Type		( Type, Kind, PredType, ThetaType, RhoType, TauType,
-			)
+import TcType		( Type, Kind, PredType, ThetaType, TauType, RhoType )
 import ErrUtils		( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
 
 import Bag		( Bag, emptyBag, isEmptyBag,
@@ -394,6 +391,8 @@ tryTc recover main down env
 	m_errs_var <- newIORef (emptyBag,emptyBag)
 	catch (my_main m_errs_var) (\ _ -> my_recover m_errs_var)
   where
+    errs_var = getTcErrs down
+
     my_recover m_errs_var
       = do warns_and_errs <- readIORef m_errs_var
 	   recover warns_and_errs down env
@@ -406,7 +405,13 @@ tryTc recover main down env
 		-- errors along the way.
 	    (m_warns, m_errs) <- readIORef m_errs_var
 	    if isEmptyBag m_errs then
-		return result
+		-- No errors, so return normally, but don't lose the warnings
+		if isEmptyBag m_warns then
+		   return result
+		else
+		   do (warns, errs) <- readIORef errs_var
+		      writeIORef errs_var (warns `unionBags` m_warns, errs)
+		      return result
 	      else
 		give_up		-- This triggers the catch
 
@@ -524,6 +529,9 @@ tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r
 -- Usual thing
 tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env
 tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env
+
+tcPopErrCtxt :: Either_TcM r -> Either_TcM  r
+tcPopErrCtxt m down env = m (popErrCtxt down) env
 \end{code}
 
 
@@ -544,11 +552,11 @@ tcGetUnique down env
   where
     u_var = getUniqSupplyVar down
 
-tcGetUniques :: Int -> NF_TcM [Unique]
-tcGetUniques n down env
+tcGetUniques :: NF_TcM [Unique]
+tcGetUniques down env
   = do	uniq_supply <- readIORef u_var
 	let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
-	    uniqs		      = uniqsFromSupply n uniq_s
+	    uniqs		      = uniqsFromSupply uniq_s
 	writeIORef u_var new_uniq_supply
 	return uniqs
   where
@@ -607,6 +615,10 @@ getErrCtxt (TcDown{tc_ctxt=ctxt}) = ctxt
 setErrCtxt down msg = down{tc_ctxt=[msg]}
 addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
 
+popErrCtxt down = case tc_ctxt down of
+			[]     -> down
+			m : ms -> down{tc_ctxt = ms}
+
 doptsTc :: DynFlag -> TcM Bool
 doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
    = return (dopt dflag dflags)