From: sof <unknown>
Date: Thu, 2 Oct 2003 19:21:00 +0000 (+0000)
Subject: [project @ 2003-10-02 19:20:59 by sof]
X-Git-Tag: Approx_11550_changesets_converted~394
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=962aaded9a544188b7d86639ab4993af205e9d72;p=ghc-hetmet.git

[project @ 2003-10-02 19:20:59 by sof]
Extend -Werror's scope to also include the desugarer.

Note: -Werror doesn't give you the union of warnings from the renamer,
      TC and desugarer before bailing out, but one pass at a time.
---

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 7c5cc8c..5b93642 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -32,9 +32,10 @@ import Id		( Id )
 import NameEnv		( lookupNameEnv )
 import VarEnv
 import VarSet
-import Bag		( isEmptyBag, mapBag )
+import Bag		( isEmptyBag, mapBag, emptyBag )
 import CoreLint		( showPass, endPass )
-import ErrUtils		( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, addShortWarnLocLine )
+import ErrUtils		( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, 
+			  addShortWarnLocLine, errorsFound )
 import Outputable
 import qualified Pretty
 import UniqSupply	( mkSplitUniqSupply )
@@ -52,7 +53,7 @@ import DATA_IOREF	( readIORef )
 
 \begin{code}
 deSugar :: HscEnv -> PersistentCompilerState
-        -> TcGblEnv -> IO ModGuts
+        -> TcGblEnv -> IO (Maybe ModGuts)
 
 deSugar hsc_env pcs
         (TcGblEnv { tcg_mod      = mod,
@@ -76,14 +77,20 @@ deSugar hsc_env pcs
 		= initDs dflags us lookup mod
 			 (dsProgram binds rules fords)
 	
-	      warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns)
+	      warns    = mapBag mk_warn ds_warns
+	      warn_doc = pprBagOfWarnings warns
 
 	-- Display any warnings
         ; doIfSet (not (isEmptyBag ds_warns))
 		  (printErrs warn_doc)
 
+	    -- if warnings are considered errors, leave.
+	; if errorsFound dflags (warns, emptyBag)
+	   then return Nothing
+	   else do {
+
 	-- Lint result if necessary
-        ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds
+          endPass dflags "Desugar" Opt_D_dump_ds ds_binds
 
 	-- Dump output
 	; doIfSet (dopt Opt_D_dump_ds dflags) 
@@ -108,8 +115,8 @@ deSugar hsc_env pcs
 		mg_binds    = ds_binds,
 		mg_foreign  = ds_fords }
 	
-        ; return mod_guts
-	}
+        ; return (Just mod_guts)
+	}}
 
   where
     dflags       = hsc_dflags hsc_env
@@ -148,7 +155,8 @@ deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr
 	; let (core_expr, ds_warns) = initDs dflags us lookup this_mod (dsExpr tc_expr)    
 	      warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns)
 
-	-- Display any warnings
+	-- Display any warnings 
+	-- Note: if -Werror is used, we don't signal an error here.
         ; doIfSet (not (isEmptyBag ds_warns))
 		  (printErrs warn_doc)
 
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index ed6f405..9b42afc 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -322,9 +322,11 @@ hscFrontEnd hsc_env pcs_ch location = do {
  	    -------------------
  	    -- DESUGAR
  	    -------------------
-	; ds_result <- _scc_ "DeSugar" 
-		       deSugar hsc_env pcs_tc tc_result
-	; return (Right (pcs_tc, ds_result))
+	; maybe_ds_result <- _scc_ "DeSugar" 
+			       deSugar hsc_env pcs_tc tc_result
+	; case maybe_ds_result of
+	    Nothing        -> return (Left (HscFail pcs_ch));
+	    Just ds_result -> return (Right (pcs_tc, ds_result));
 	}}}}}