Commit 962aaded authored by sof's avatar sof

[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.
parent a9190910
...@@ -32,9 +32,10 @@ import Id ( Id ) ...@@ -32,9 +32,10 @@ import Id ( Id )
import NameEnv ( lookupNameEnv ) import NameEnv ( lookupNameEnv )
import VarEnv import VarEnv
import VarSet import VarSet
import Bag ( isEmptyBag, mapBag ) import Bag ( isEmptyBag, mapBag, emptyBag )
import CoreLint ( showPass, endPass ) import CoreLint ( showPass, endPass )
import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, addShortWarnLocLine ) import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
addShortWarnLocLine, errorsFound )
import Outputable import Outputable
import qualified Pretty import qualified Pretty
import UniqSupply ( mkSplitUniqSupply ) import UniqSupply ( mkSplitUniqSupply )
...@@ -52,7 +53,7 @@ import DATA_IOREF ( readIORef ) ...@@ -52,7 +53,7 @@ import DATA_IOREF ( readIORef )
\begin{code} \begin{code}
deSugar :: HscEnv -> PersistentCompilerState deSugar :: HscEnv -> PersistentCompilerState
-> TcGblEnv -> IO ModGuts -> TcGblEnv -> IO (Maybe ModGuts)
deSugar hsc_env pcs deSugar hsc_env pcs
(TcGblEnv { tcg_mod = mod, (TcGblEnv { tcg_mod = mod,
...@@ -76,14 +77,20 @@ deSugar hsc_env pcs ...@@ -76,14 +77,20 @@ deSugar hsc_env pcs
= initDs dflags us lookup mod = initDs dflags us lookup mod
(dsProgram binds rules fords) (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 -- Display any warnings
; doIfSet (not (isEmptyBag ds_warns)) ; doIfSet (not (isEmptyBag ds_warns))
(printErrs warn_doc) (printErrs warn_doc)
-- if warnings are considered errors, leave.
; if errorsFound dflags (warns, emptyBag)
then return Nothing
else do {
-- Lint result if necessary -- Lint result if necessary
; endPass dflags "Desugar" Opt_D_dump_ds ds_binds endPass dflags "Desugar" Opt_D_dump_ds ds_binds
-- Dump output -- Dump output
; doIfSet (dopt Opt_D_dump_ds dflags) ; doIfSet (dopt Opt_D_dump_ds dflags)
...@@ -108,8 +115,8 @@ deSugar hsc_env pcs ...@@ -108,8 +115,8 @@ deSugar hsc_env pcs
mg_binds = ds_binds, mg_binds = ds_binds,
mg_foreign = ds_fords } mg_foreign = ds_fords }
; return mod_guts ; return (Just mod_guts)
} }}
where where
dflags = hsc_dflags hsc_env dflags = hsc_dflags hsc_env
...@@ -148,7 +155,8 @@ deSugarExpr hsc_env pcs this_mod rdr_env type_env tc_expr ...@@ -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) ; let (core_expr, ds_warns) = initDs dflags us lookup this_mod (dsExpr tc_expr)
warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns) 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)) ; doIfSet (not (isEmptyBag ds_warns))
(printErrs warn_doc) (printErrs warn_doc)
......
...@@ -322,9 +322,11 @@ hscFrontEnd hsc_env pcs_ch location = do { ...@@ -322,9 +322,11 @@ hscFrontEnd hsc_env pcs_ch location = do {
------------------- -------------------
-- DESUGAR -- DESUGAR
------------------- -------------------
; ds_result <- _scc_ "DeSugar" ; maybe_ds_result <- _scc_ "DeSugar"
deSugar hsc_env pcs_tc tc_result deSugar hsc_env pcs_tc tc_result
; return (Right (pcs_tc, ds_result)) ; case maybe_ds_result of
Nothing -> return (Left (HscFail pcs_ch));
Just ds_result -> return (Right (pcs_tc, ds_result));
}}}}} }}}}}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment