Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
3b2cd7b3
Commit
3b2cd7b3
authored
Sep 14, 2008
by
Thomas Schilling
Browse files
Return instead of print warnings and errors in desugarer.
parent
7b2ac617
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/deSugar/Desugar.lhs
View file @
3b2cd7b3
...
...
@@ -49,7 +49,7 @@ import Data.IORef
%************************************************************************
\begin{code}
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Maybe ModGuts)
deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (
Messages,
Maybe ModGuts)
-- Can modify PCS by faulting in more declarations
deSugar hsc_env
...
...
@@ -80,23 +80,27 @@ deSugar hsc_env
; let auto_scc = mkAutoScc mod export_set
; let target = hscTarget dflags
; let hpcInfo = emptyHpcInfo other_hpc_info
; mb_res <- case target of
HscNothing -> return (Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
_ -> do (binds_cvr,ds_hpc_info, modBreaks)
<- if (opt_Hpc
|| target == HscInterpreted)
&& (not (isHsBoot hsc_src))
then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds_cvr
; (ds_fords, foreign_prs) <- dsForeigns fords
; let all_prs = foreign_prs ++ core_prs
; ds_rules <- mapM dsRule rules
; return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
}
; (msgs, mb_res)
<- case target of
HscNothing ->
return (emptyMessages,
Just ([], [], NoStubs, hpcInfo, emptyModBreaks))
_ -> do
(binds_cvr,ds_hpc_info, modBreaks)
<- if (opt_Hpc
|| target == HscInterpreted)
&& (not (isHsBoot hsc_src))
then addCoverageTicksToBinds dflags mod mod_loc (typeEnvTyCons type_env) binds
else return (binds, hpcInfo, emptyModBreaks)
initDs hsc_env mod rdr_env type_env $ do
core_prs <- dsTopLHsBinds auto_scc binds_cvr
(ds_fords, foreign_prs) <- dsForeigns fords
let all_prs = foreign_prs ++ core_prs
ds_rules <- mapM dsRule rules
return (all_prs, catMaybes ds_rules, ds_fords, ds_hpc_info, modBreaks)
; case mb_res of {
Nothing -> return Nothing ;
Nothing -> return
(msgs,
Nothing
)
;
Just (all_prs, ds_rules, ds_fords,ds_hpc_info, modBreaks) -> do
{ -- Add export flags to bindings
...
...
@@ -142,7 +146,7 @@ deSugar hsc_env
mg_modBreaks = modBreaks,
mg_vect_info = noVectInfo
}
; return (Just mod_guts)
; return (
msgs,
Just mod_guts)
}}}
mkAutoScc :: Module -> NameSet -> AutoScc
...
...
@@ -162,25 +166,25 @@ mkAutoScc mod exports
deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> LHsExpr Id
-> IO (Maybe CoreExpr)
-> IO (
Messages,
Maybe CoreExpr)
-- Prints its own errors; returns Nothing if error occurred
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
= do {
let dflags = hsc_dflags hsc_env
;
showPass dflags "Desugar"
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
= do
let dflags = hsc_dflags hsc_env
showPass dflags "Desugar"
-- Do desugaring
;
mb_core_expr <- initDs hsc_env this_mod rdr_env type_env $
dsLExpr tc_expr
-- Do desugaring
(msgs,
mb_core_expr
)
<- initDs hsc_env this_mod rdr_env type_env $
dsLExpr tc_expr
;
case mb_core_expr of
{
Nothing -> return Nothing
;
Just expr -> do
{
case mb_core_expr of
Nothing -> return
(msgs,
Nothing
)
Just expr -> do
-- Dump output
dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
-- Dump output
dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr expr)
;
return (Just expr)
} } }
return (
msgs,
Just expr)
-- addExportFlags
-- Set the no-discard flag if either
...
...
compiler/deSugar/DsMonad.lhs
View file @
3b2cd7b3
...
...
@@ -156,7 +156,7 @@ data DsMetaVal
initDs :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> DsM a
-> IO (Maybe a)
-> IO (
Messages,
Maybe a)
-- Print errors and warnings, if any arise
initDs hsc_env mod rdr_env type_env thing_inside
...
...
@@ -170,7 +170,6 @@ initDs hsc_env mod rdr_env type_env thing_inside
-- Display any errors and warnings
-- Note: if -Werror is used, we don't signal an error here.
; msgs <- readIORef msg_var
; printErrorsAndWarnings dflags msgs
; let final_res | errorsFound dflags msgs = Nothing
| otherwise = case either_res of
...
...
@@ -180,7 +179,7 @@ initDs hsc_env mod rdr_env type_env thing_inside
-- a UserError exception. Then it should have put an error
-- message in msg_var, so we just discard the exception
; return final_res }
; return
(msgs,
final_res
)
}
initDsTc :: DsM a -> TcM a
initDsTc thing_inside
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment