From 99e7276982fe41dca0098e37a9cbf71091c3e275 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= <dxld@darkboxed.org>
Date: Sat, 25 May 2019 13:57:45 +0200
Subject: 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.
---
 compiler/main/DriverPipeline.hs                    | 12 ++++-
 compiler/main/GhcMake.hs                           | 17 +------
 testsuite/tests/driver/T8602/T8602.stderr          |  4 +-
 .../downsweep/PartialDownsweep.darwin.stderr       | 16 ++++++
 .../tests/ghc-api/downsweep/PartialDownsweep.hs    | 57 ++++++++++++++++++----
 .../ghc-api/downsweep/PartialDownsweep.stderr      | 14 +++++-
 testsuite/tests/ghc-api/downsweep/all.T            |  3 ++
 7 files changed, 95 insertions(+), 28 deletions(-)
 create mode 100644 testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr

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 {..}
diff --git a/testsuite/tests/driver/T8602/T8602.stderr b/testsuite/tests/driver/T8602/T8602.stderr
index eb28842f54..4b0c4a5373 100644
--- a/testsuite/tests/driver/T8602/T8602.stderr
+++ b/testsuite/tests/driver/T8602/T8602.stderr
@@ -1,2 +1,4 @@
 A B C
-`t8602.sh' failed in phase `Haskell pre-processor'. (Exit code: 1)
+
+A.hs:1:1: error:
+    `t8602.sh' failed in phase `Haskell pre-processor'. (Exit code: 1)
diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr
new file mode 100644
index 0000000000..c9cd0f216d
--- /dev/null
+++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr
@@ -0,0 +1,16 @@
+== Parse error in export list
+== Parse error in export list with bypass module
+== Parse error in import list
+== CPP preprocessor error
+
+B.hs:2:2:  #elif without #if
+     #elif <- cpp error here
+ ^
+1 error generated.
+== CPP preprocessor error with bypass
+
+B.hs:2:2:  #elif without #if
+     #elif <- cpp error here
+ ^
+1 error generated.
+== Import error
diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
index f3c379a3fb..fb91fb6c1f 100644
--- a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
+++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
@@ -45,7 +45,8 @@ main = do
   runGhc (Just libdir) $ do
     dflags0 <- getSessionDynFlags
     (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $
-        [ -- "-v3"
+        [ "-fno-diagnostics-show-caret"
+        -- , "-v3"
         ] ++ args
     _ <- setSessionDynFlags dflags1
 
@@ -65,6 +66,23 @@ main = do
          sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A"]
        )
 
+    go "Parse error in export list with bypass module"
+        [ [ "module A where"
+          , "import B"
+          , "import C"
+          ]
+        , [ "module B !parse_error where"
+          , "import D"
+          ]
+        , [ "module C where"
+          , "import D"
+          ]
+        , [ "module D where"
+          ]
+        ]
+       (\mss -> return $
+           sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "C", "D"]
+       )
     go "Parse error in import list"
         [ [ "module A where"
           , "import B"
@@ -83,24 +101,40 @@ main = do
          sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "B"]
        )
 
-    go "Parse error in export list with bypass module"
+    go "CPP preprocessor error"
         [ [ "module A where"
           , "import B"
-          , "import C"
           ]
-        , [ "module B !parse_error where"
-          , "import D"
+        , [ "{-# LANGUAGE CPP #-}"
+          , "#elif <- cpp error here"
+          , "module B where"
+          , "import C"
           ]
         , [ "module C where"
-          , "import D"
           ]
-        , [ "module D where"
+        ]
+       (\mss -> return $
+         sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A"]
+       )
+
+    go "CPP preprocessor error with bypass"
+        [ [ "module A where"
+          , "import B"
+          , "import C"
+          ]
+        , [ "{-# LANGUAGE CPP #-}"
+          , "#elif <- cpp error here"
+          , "module B where"
+          , "import C"
+          ]
+        , [ "module C where"
           ]
         ]
        (\mss -> return $
-           sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "C", "D"]
+         sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "C"]
        )
 
+
   errored <- readIORef any_failed
   when errored $ exitFailure
   return ()
@@ -125,5 +159,8 @@ go label mods cnd =
 
 
 writeMod :: [String] -> IO ()
-writeMod src@(head -> stripPrefix "module " -> Just (takeWhile (/=' ') -> mod))
-  = writeFile (mod++".hs") $ unlines src
+writeMod src =
+    writeFile (mod++".hs") $ unlines src
+  where
+    Just modline = find ("module" `isPrefixOf`) src
+    Just (takeWhile (/=' ') -> mod) = stripPrefix "module " modline
diff --git a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr
index 11fd4b73c8..9e5f6d83dc 100644
--- a/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr
+++ b/testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr
@@ -1,3 +1,15 @@
 == Parse error in export list
-== Parse error in import list
 == Parse error in export list with bypass module
+== Parse error in import list
+== CPP preprocessor error
+
+B.hs:2:0: error:
+     error: #elif without #if
+     #elif <- cpp error here
+     
+== CPP preprocessor error with bypass
+
+B.hs:2:0: error:
+     error: #elif without #if
+     #elif <- cpp error here
+     
diff --git a/testsuite/tests/ghc-api/downsweep/all.T b/testsuite/tests/ghc-api/downsweep/all.T
index d7ed778f8e..18ed26ac88 100644
--- a/testsuite/tests/ghc-api/downsweep/all.T
+++ b/testsuite/tests/ghc-api/downsweep/all.T
@@ -1,5 +1,8 @@
 test('PartialDownsweep',
      [ extra_run_opts('"' + config.libdir + '"')
+     , when(opsys('darwin'),
+             use_specs({'stderr' : 'PartialDownsweep.darwin.stderr'})
+           )
      ],
      compile_and_run,
      ['-package ghc'])
-- 
cgit v1.2.1