[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 (file)
--- 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 (file)
--- 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));
        }}}}}