From: Thomas Schilling <nominolo@googlemail.com>
Date: Sun, 14 Sep 2008 16:36:41 +0000 (+0000)
Subject: Return instead of print warnings and errors in desugarer.
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=3b2cd7b311da1e7056ef66b42efc2571add5a8aa

Return instead of print warnings and errors in desugarer.
---

diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs
index 80b0dcb..ab9f8c7 100644
--- a/compiler/deSugar/Desugar.lhs
+++ b/compiler/deSugar/Desugar.lhs
@@ -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 
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index 1f01e15..145ba9e 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -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