Catch preprocessor errors in downsweep

This changes the way preprocessor failures are presented to the
user. Previously the user would simply get an unlocated message on stderr
such as:

    `gcc' failed in phase `C pre-processor'. (Exit code: 1)

Now at the problematic source file is mentioned:

    A.hs:1:1: error:
        `gcc' failed in phase `C pre-processor'. (Exit code: 1)

This also makes live easier for GHC API clients as the preprocessor error
is now thrown as a SourceError exception.

2 files changed, 13 insertions, 16 deletions

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 9ac973cbc4..78e4a810d7 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -64,6 +64,8 @@ import Hooks
 import qualified GHC.LanguageExtensions as LangExt
 import FileCleanup
 import Ar
+import Bag              ( unitBag )
+import FastString       ( mkFastString )
 
 import Exception
 import System.Directory
@@ -91,8 +93,11 @@ preprocess :: HscEnv
            -> Maybe StringBuffer
            -- ^ optional buffer to use instead of reading input file
            -> Maybe Phase -- ^ starting phase
-           -> IO (DynFlags, FilePath)
+           -> IO (Either ErrorMessages (DynFlags, FilePath))
 preprocess hsc_env input_fn mb_input_buf mb_phase =
+  handleSourceError (\err -> return (Left (srcErrorMessages err))) $
+  ghandle handler $
+  fmap Right $
   ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
   runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)
         Nothing
@@ -101,6 +106,11 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
         (Temporary TFL_GhcSession)
         Nothing{-no ModLocation-}
         []{-no foreign objects-}
+  where
+    srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
+    handler (ProgramError msg) = return $ Left $ unitBag $
+        mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg
+    handler ex = throwGhcExceptionIO ex
 
 -- ---------------------------------------------------------------------------
 
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 341356f775..f3a1cfaaca 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -2489,19 +2489,6 @@ getObjTimestamp location is_boot
   = if is_boot == IsBoot then return Nothing
                          else modificationTimeIfExists (ml_obj_file location)
 
-
-preprocessFile :: HscEnv
-               -> FilePath
-               -> Maybe Phase -- ^ Starting phase
-               -> Maybe (StringBuffer,UTCTime)
-               -> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile hsc_env src_fn mb_phase maybe_buf
-  = do
-        (dflags', hspp_fn)
-            <- preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
-        buf <- hGetStringBuffer hspp_fn
-        return (dflags', hspp_fn, buf)
-
 data PreprocessedImports
   = PreprocessedImports
       { pi_local_dflags :: DynFlags
@@ -2523,8 +2510,8 @@ getPreprocessedImports
     -> ExceptT ErrorMessages IO PreprocessedImports
 getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
   (pi_local_dflags, pi_hspp_fn)
-      <- liftIO $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
-  pi_hscpp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
+      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
+  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
   (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)
       <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
   return PreprocessedImports {..}