Throw SourceErrors instead of ProgramErrors in main/HeaderInfo.

Parse errors during dependency analysis or options parsing really
shouldn't kill GHC; this is particularly annoying for GHC API clients.

compiler/main/DriverPipeline.hs

@@ -667,7 +667,7 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
        (dflags, unhandled_flags, warns)
            <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
        liftIO $ handleFlagWarnings dflags warns  -- XXX: may exit the program
-       liftIO $ checkProcessArgsResult unhandled_flags -- XXX: may throw program error
+       checkProcessArgsResult unhandled_flags
 
        if not (dopt Opt_Cpp dflags) then
            -- no need to preprocess CPP, just pass input file along
@@ -726,8 +726,8 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
                     m <- liftIO $ getCoreModuleName input_fn
                     return (Nothing, mkModuleName m, [], [])
 
-                _           -> liftIO $ do
-                    buf <- hGetStringBuffer input_fn
+                _           -> do
+                    buf <- liftIO $ hGetStringBuffer input_fn
                     (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
                     return (Just buf, mod_name, imps, src_imps)
 

compiler/main/GHC.hs

@@ -2029,7 +2029,7 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
 	(dflags', hspp_fn, buf)
 	    <- preprocessFile hsc_env file mb_phase maybe_buf
 
-        (srcimps,the_imps, L _ mod_name) <- liftIO $ getImports dflags' buf hspp_fn file
+        (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
 
 	-- Make a ModLocation for this file
 	location <- liftIO $ mkHomeModLocation dflags mod_name file
@@ -2161,7 +2161,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
 	-- Preprocess the source file and get its imports
 	-- The dflags' contains the OPTIONS pragmas
 	(dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
-        (srcimps, the_imps, L mod_loc mod_name) <- liftIO $ getImports dflags' buf hspp_fn src_fn
+        (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
 
 	when (mod_name /= wanted_mod) $
 		throwOneError $ mkPlainErrMsg mod_loc $ 

compiler/main/HeaderInfo.hs

@@ -37,26 +37,39 @@ import ErrUtils
 import Util
 import Outputable
 import Pretty           ()
-import Panic
 import Maybes
-import Bag		( emptyBag, listToBag )
+import Bag		( emptyBag, listToBag, unitBag )
 
+import MonadUtils       ( MonadIO )
 import Exception
 import Control.Monad
-import System.Exit
 import System.IO
 import Data.List
 
-getImports :: DynFlags -> StringBuffer -> FilePath -> FilePath
-    -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName)
+------------------------------------------------------------------------------
+
+-- | Parse the imports of a source file.
+--
+-- Throws a 'SourceError' if parsing fails.
+getImports :: GhcMonad m =>
+              DynFlags
+           -> StringBuffer -- ^ Parse this.
+           -> FilePath     -- ^ Filename the buffer came from.  Used for
+                           --   reporting parse error locations.
+           -> FilePath     -- ^ The original source filename (used for locations
+                           --   in the function result)
+           -> m ([Located ModuleName], [Located ModuleName], Located ModuleName)
+              -- ^ The source imports, normal imports, and the module name.
 getImports dflags buf filename source_filename = do
   let loc  = mkSrcLoc (mkFastString filename) 1 0
   case unP parseHeader (mkPState buf loc dflags) of
-	PFailed span err -> parseError span err
-	POk pst rdr_module -> do
-          let ms = getMessages pst
-          printErrorsAndWarnings dflags ms
-          when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
+    PFailed span err -> parseError span err
+    POk pst rdr_module -> do
+      let ms@(warns, errs) = getMessages pst
+      logWarnings warns
+      if errorsFound dflags ms
+        then liftIO $ throwIO $ mkSrcErr errs
+        else
 	  case rdr_module of
 	    L _ (HsModule mb_mod _ imps _ _ _ _) ->
 	      let
@@ -71,7 +84,7 @@ getImports dflags buf filename source_filename = do
 	      in
 	      return (source_imps, ordinary_imps, mod)
   
-parseError :: SrcSpan -> Message -> IO a
+parseError :: GhcMonad m => SrcSpan -> Message -> m a
 parseError span err = throwOneError $ mkPlainErrMsg span err
 
 -- we aren't interested in package imports here, filter them out
@@ -186,14 +199,14 @@ getOptions' dflags buf filename
 -----------------------------------------------------------------------------
 -- Complain about non-dynamic flags in OPTIONS pragmas
 
-checkProcessArgsResult :: [Located String] -> IO ()
+checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
 checkProcessArgsResult flags
   = when (notNull flags) $
-        ghcError $ ProgramError $ showSDoc $ vcat $ map f flags
-    where f (L loc flag)
-              = hang (ppr loc <> char ':') 4
-                     (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
-                      text flag)
+      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
+    where mkMsg (L loc flag)
+              = mkPlainErrMsg loc $
+                  (text "unknown flag in  {-# OPTIONS #-} pragma:" <+>
+                   text flag)
 
 -----------------------------------------------------------------------------
 
@@ -209,15 +222,15 @@ checkExtension (L l ext)
 
 languagePragParseError :: SrcSpan -> a
 languagePragParseError loc =
-  pgmError 
-   (showSDoc (mkLocMessage loc (
-     text "cannot parse LANGUAGE pragma: comma-separated list expected")))
+  throw $ mkSrcErr $ unitBag $
+     (mkPlainErrMsg loc $
+       text "cannot parse LANGUAGE pragma: comma-separated list expected")
 
 unsupportedExtnError :: SrcSpan -> String -> a
 unsupportedExtnError loc unsup =
-  pgmError (showSDoc (mkLocMessage loc (
-                text "unsupported extension: " <>
-                text unsup)))
+  throw $ mkSrcErr $ unitBag $
+    mkPlainErrMsg loc $
+        text "unsupported extension: " <> text unsup
 
 
 optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages