[project @ 2005-05-31 12:45:03 by simonmar]

Fix some reporting of errors in the GHC API: errors during the
downsweep were thrown as exceptions; now they're reported via the
(Messages->IO ()) callback in the same way as other errors.

getModuleInfo no longer prints anything on stdout.  It does ignore
error messages and return Nothing, however - we should fix this and
return the error messages at some point.

The ErrMsg type can now be thrown as an exception.  This can be a
convenient alternative if collecting multiple error messages isn't
required.  We do this in the downsweep now.

4 files changed, 85 insertions, 52 deletions

diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index e53e40cab0..12d3e43ad4 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -39,6 +39,7 @@ import StaticFlags	( opt_ErrorSpans )
 import System		( ExitCode(..), exitWith )
 import DATA_IOREF
 import IO		( hPutStrLn, stderr )
+import DYNAMIC		( TyCon, mkTyCon, Typeable(..), mkTyConApp )
 
 
 -- -----------------------------------------------------------------------------
@@ -71,6 +72,12 @@ data ErrMsg = ErrMsg {
 	-- NB  Pretty.Doc not SDoc: we deal with the printing style (in ptic 
 	-- whether to qualify an External Name) at the error occurrence
 
+-- So we can throw these things as exceptions
+errMsgTc :: TyCon
+errMsgTc = mkTyCon "ErrMsg"
+instance Typeable ErrMsg where
+  typeOf _ = mkTyConApp errMsgTc []
+
 type WarnMsg = ErrMsg
 
 -- A short (one-line) error message, with context to tell us whether
diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs
index 43f271d459..9fb360d366 100644
--- a/ghc/compiler/main/GHC.hs
+++ b/ghc/compiler/main/GHC.hs
@@ -152,7 +152,7 @@ import IfaceSyn		( IfaceDecl )
 import SrcLoc		( srcLocSpan, interactiveSrcLoc )
 #endif
 
-import Packages		( initPackages )
+import Packages		( initPackages, isHomeModule )
 import NameSet		( NameSet, nameSetToList, elemNameSet )
 import RdrName		( GlobalRdrEnv, GlobalRdrElt(..), RdrName, 
 			  globalRdrEnvElts )
@@ -185,7 +185,9 @@ import Module
 import FiniteMap
 import Panic
 import Digraph
-import ErrUtils		( showPass, Messages, putMsg, debugTraceMsg, mkLocMessage )
+import Bag		( unitBag, emptyBag )
+import ErrUtils		( showPass, Messages, putMsg, debugTraceMsg,
+			  mkPlainErrMsg, pprBagOfErrors )
 import qualified ErrUtils
 import Util
 import StringBuffer	( StringBuffer, hGetStringBuffer )
@@ -229,7 +231,12 @@ defaultErrorHandler inner =
 	   exitWith (ExitFailure 1)
          ) $
 
-  -- all error messages are propagated as exceptions
+  -- program errors: messages with locations attached.  Sometimes it is
+  -- convenient to just throw these as exceptions.
+  handleDyn (\dyn -> do printErrs (pprBagOfErrors (unitBag dyn))
+			exitWith (ExitFailure 1)) $
+
+  -- error messages propagated as exceptions
   handleDyn (\dyn -> do
   		hFlush stdout
   		case dyn of
@@ -380,7 +387,7 @@ guessTarget file Nothing
 
 -- Perform a dependency analysis starting from the current targets
 -- and update the session with the new module graph.
-depanal :: Session -> [Module] -> IO ()
+depanal :: Session -> [Module] -> IO (Either Messages ModuleGraph)
 depanal (Session ref) excluded_mods = do
   hsc_env <- readIORef ref
   let
@@ -395,8 +402,7 @@ depanal (Session ref) excluded_mods = do
 		     text "Chasing modules from: ",
 	     		hcat (punctuate comma (map pprTarget targets))]))
 
-  graph <- downsweep hsc_env old_graph excluded_mods
-  writeIORef ref hsc_env{ hsc_mod_graph=graph }
+  downsweep hsc_env old_graph excluded_mods
 
 {-
 -- | The result of load.
@@ -435,13 +441,17 @@ loadMsgs s@(Session ref) how_much msg_act
 	-- even if we don't get a fully successful upsweep, the full module
 	-- graph is still retained in the Session.  We can tell which modules
 	-- were successfully loaded by inspecting the Session's HPT.
-	depanal s []
+	mb_graph <- depanal s []
+	case mb_graph of
+	   Left msgs -> do msg_act msgs; return Failed
+	   Right mod_graph -> loadMsgs2 s how_much msg_act mod_graph 
 
+loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
 	hsc_env <- readIORef ref
+	writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
 
         let hpt1      = hsc_HPT hsc_env
         let dflags    = hsc_dflags hsc_env
-	let mod_graph = hsc_mod_graph hsc_env
 
         let ghci_mode = ghcMode (hsc_dflags hsc_env) -- this never changes
         let verb      = verbosity dflags
@@ -1213,12 +1223,14 @@ downsweep :: HscEnv
 	  -> [ModSummary]	-- Old summaries
 	  -> [Module]		-- Ignore dependencies on these; treat them as
 				-- if they were package modules
-	  -> IO [ModSummary]
+	  -> IO (Either Messages [ModSummary])
 downsweep hsc_env old_summaries excl_mods
-   = do rootSummaries <- mapM getRootSummary roots
-	checkDuplicates rootSummaries
-        loop (concatMap msDeps rootSummaries) 
-	     (mkNodeMap rootSummaries)
+   = -- catch error messages and return them
+     handleDyn (\err_msg -> return (Left (emptyBag, unitBag err_msg))) $ do
+       rootSummaries <- mapM getRootSummary roots
+       checkDuplicates rootSummaries
+       summs <- loop (concatMap msDeps rootSummaries) (mkNodeMap rootSummaries)
+       return (Right summs)
      where
 	roots = hsc_targets hsc_env
 
@@ -1440,10 +1452,9 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc
         (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn
 
 	when (mod_name /= wanted_mod) $
-		throwDyn (ProgramError 
-		   (showSDoc (mkLocMessage mod_loc $ 
+		throwDyn $ mkPlainErrMsg mod_loc $ 
 			      text "file name does not match module name"
-			      <+> quotes (ppr mod_name))))
+			      <+> quotes (ppr mod_name)
 
 		-- Find the object timestamp, and return the summary
 	obj_timestamp <- getObjTimestamp location is_boot
@@ -1502,12 +1513,10 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time))
 noModError :: DynFlags -> SrcSpan -> Module -> FindResult -> IO ab
 -- ToDo: we don't have a proper line number for this error
 noModError dflags loc wanted_mod err
-  = throwDyn $ ProgramError $ showSDoc $
-    mkLocMessage loc $ cantFindError dflags wanted_mod err
+  = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err
 				
 noHsFileErr loc path
-  = throwDyn $ CmdLineError $ showSDoc $
-    mkLocMessage loc $ text "Can't find" <+> text path
+  = throwDyn $ mkPlainErrMsg loc $ text "Can't find" <+> text path
  
 packageModErr mod
   = throwDyn (CmdLineError (showSDoc (text "module" <+>
@@ -1572,42 +1581,55 @@ data ModuleInfo = ModuleInfo {
 -- | Request information about a loaded 'Module'
 getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo)
 getModuleInfo s mdl = withSession s $ \hsc_env -> do
-  case lookupModuleEnv (hsc_HPT hsc_env) mdl of
-    Nothing  -> do
+  let mg = hsc_mod_graph hsc_env
+  if mdl `elem` map ms_mod mg
+	then getHomeModuleInfo hsc_env mdl
+	else do
+  if isHomeModule (hsc_dflags hsc_env) mdl
+	then return Nothing
+	else getPackageModuleInfo hsc_env mdl
+   -- getPackageModuleInfo will attempt to find the interface, so
+   -- we don't want to call it for a home module, just in case there
+   -- was a problem loading the module and the interface doesn't
+   -- exist... hence the isHomeModule test here.
+
+getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)
+getPackageModuleInfo hsc_env mdl = do
 #ifdef GHCI
-	mb_names <- getModuleExports hsc_env mdl
-	case mb_names of
-	   Nothing -> return Nothing
-	   Just names -> do
-		eps <- readIORef (hsc_EPS hsc_env)
-		let 
-		    pte    = eps_PTE eps
-		    n_list = nameSetToList names
-		    tys    = [ ty | name <- n_list,
-				    Just ty <- [lookupTypeEnv pte name] ]
-		--
-		return (Just (ModuleInfo {
-				minf_type_env  = mkTypeEnv tys,
-				minf_exports   = names,
-				minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names mdl,
-				minf_instances = error "getModuleInfo: instances for package module unimplemented"
-			}))
+  (_msgs, mb_names) <- getModuleExports hsc_env mdl
+  case mb_names of
+    Nothing -> return Nothing
+    Just names -> do
+	eps <- readIORef (hsc_EPS hsc_env)
+	let 
+	    pte    = eps_PTE eps
+	    n_list = nameSetToList names
+	    tys    = [ ty | name <- n_list,
+			    Just ty <- [lookupTypeEnv pte name] ]
+	--
+	return (Just (ModuleInfo {
+			minf_type_env  = mkTypeEnv tys,
+			minf_exports   = names,
+			minf_rdr_env   = Just $! nameSetToGlobalRdrEnv names mdl,
+			minf_instances = error "getModuleInfo: instances for package module unimplemented"
+		}))
 #else
-	-- bogusly different for non-GHCI (ToDo)
-	return Nothing
+  -- bogusly different for non-GHCI (ToDo)
+  return Nothing
 #endif
-    Just hmi -> 
-	let details = hm_details hmi in
-	return (Just (ModuleInfo {
+
+getHomeModuleInfo hsc_env mdl = 
+  case lookupModuleEnv (hsc_HPT hsc_env) mdl of
+    Nothing  -> return Nothing
+    Just hmi -> do
+      let details = hm_details hmi
+      return (Just (ModuleInfo {
 			minf_type_env  = md_types details,
 			minf_exports   = md_exports details,
 			minf_rdr_env   = mi_globals $! hm_iface hmi,
 			minf_instances = md_insts details
 			}))
 
-	-- ToDo: we should be able to call getModuleInfo on a package module,
-	-- even one that isn't loaded yet.
-
 -- | The list of top-level entities defined in a module
 modInfoTyThings :: ModuleInfo -> [TyThing]
 modInfoTyThings minf = typeEnvElts (minf_type_env minf)
@@ -1727,8 +1749,9 @@ setContext (Session ref) toplevs exports = do
 -- Make a GlobalRdrEnv based on the exports of the modules only.
 mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv
 mkExportEnv hsc_env mods = do
-  mb_name_sets <- mapM (getModuleExports hsc_env) mods
+  stuff <- mapM (getModuleExports hsc_env) mods
   let 
+	(_msgs, mb_name_sets) = unzip stuff
 	gres = [ nameSetToGlobalRdrEnv name_set mod
   	       | (Just name_set, mod) <- zip mb_name_sets mods ]
   --
diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs
index 77ca4b5967..6ccb8bed7a 100644
--- a/ghc/compiler/main/GetImports.hs
+++ b/ghc/compiler/main/GetImports.hs
@@ -58,8 +58,7 @@ getImports dflags buf filename = do
 	      in
 	      return (source_imps, ordinary_imps, mod_name)
   
-parseError span err = throwDyn (ProgramError err_doc)
-  where err_doc = render (pprBagOfErrors (unitBag (mkPlainErrMsg span err)))
+parseError span err = throwDyn $ mkPlainErrMsg span err
 
 isSourceIdecl (ImportDecl _ s _ _ _) = s
 
diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index 66f3f95e0b..52f3c1b195 100644
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -1095,9 +1095,13 @@ tcRnType hsc_env ictxt rdr_type
 
 \begin{code}
 #ifdef GHCI
-getModuleExports :: HscEnv -> Module -> IO (Maybe NameSet)
+-- ASSUMES that the module is either in the HomePackageTable or is
+-- a package module with an interface on disk.  If neither of these is
+-- true, then the result will be an error indicating the interface
+-- could not be found.
+getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet)
 getModuleExports hsc_env mod
-  = initTcPrintErrors hsc_env iNTERACTIVE (tcGetModuleExports mod)
+  = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
 
 tcGetModuleExports :: Module -> TcM NameSet
 tcGetModuleExports mod = do