Allow source plugins to change parser errors

In 9.4, the ability for parser source plugins to access and manipulate
non-fatal parse errors was added:
https://gitlab.haskell.org/ghc/ghc/-/wikis/migration/9.4#parser-plugins-have-a-different-type

HLS always threw an error in this situation without running the plugins
though. This commit fixes that.

Author: JakobBruenker

ghcide/src/Development/IDE/Core/Compile.hs

@@ -132,6 +132,9 @@ import qualified GHC                               as G
 import           GHC.Hs                            (LEpaComment)
 import qualified GHC.Types.Error                   as Error
 #endif
+#if MIN_VERSION_ghc(9,3,0)
+import GHC.Driver.Plugins                          (PsMessages (..))
+#endif
 
 -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
 parseModule
@@ -1219,7 +1222,7 @@ parseHeader dflags filename contents = do
      PFailedWithErrorMessages msgs ->
         throwE $ diagFromErrMsgs "parser" dflags $ msgs dflags
      POk pst rdr_module -> do
-        let (warns, errs) = getMessages' pst dflags
+        let (warns, errs) = renderMessages $ getMessages' pst dflags
 
         -- Just because we got a `POk`, it doesn't mean there
         -- weren't errors! To clarify, the GHC parser
@@ -1254,9 +1257,18 @@ parseFileContents env customPreprocessor filename ms = do
      POk pst rdr_module ->
          let
              hpm_annotations = mkApiAnns pst
-             (warns, errs) = getMessages' pst dflags
+             psMessages = getMessages' pst dflags
          in
            do
+               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
+
+               unless (null errs) $
+                  throwE $ diagFromStrings "parser" DsError errs
+
+               let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
+               (parsed', msgs) <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed psMessages
+               let (warns, errs) = renderMessages msgs
+
                -- Just because we got a `POk`, it doesn't mean there
                -- weren't errors! To clarify, the GHC parser
                -- distinguishes between fatal and non-fatal
@@ -1269,14 +1281,6 @@ parseFileContents env customPreprocessor filename ms = do
                unless (null errs) $
                  throwE $ diagFromErrMsgs "parser" dflags errs
 
-               -- Ok, we got here. It's safe to continue.
-               let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
-
-               unless (null errs) $
-                  throwE $ diagFromStrings "parser" DsError errs
-
-               let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
-               parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed
 
                -- To get the list of extra source files, we take the list
                -- that the parser gave us,

ghcide/src/Development/IDE/GHC/Compat.hs

@@ -27,6 +27,7 @@ module Development.IDE.GHC.Compat(
     reLoc,
     reLocA,
     getMessages',
+    renderMessages,
     pattern PFailedWithErrorMessages,
     isObjectLinkable,
 
@@ -268,6 +269,7 @@ import           GHC.Types.IPE
 #if MIN_VERSION_ghc(9,3,0)
 import GHC.Types.Error
 import GHC.Driver.Config.Stg.Pipeline
+import GHC.Driver.Plugins                              (PsMessages (..))
 #endif
 
 #if !MIN_VERSION_ghc(9,3,0)
@@ -390,10 +392,14 @@ type ErrMsg  = MsgEnvelope DecoratedSDoc
 type WarnMsg  = MsgEnvelope DecoratedSDoc
 #endif
 
-getMessages' :: PState -> DynFlags -> (Bag WarnMsg, Bag ErrMsg)
+#if !MIN_VERSION_ghc(9,3,0)
+type PsMessages = (Bag WarnMsg, Bag ErrMsg)
+#endif
+
+getMessages' :: PState -> DynFlags -> PsMessages
 getMessages' pst dflags =
 #if MIN_VERSION_ghc(9,3,0)
-  bimap (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) $ getPsMessages pst
+  uncurry PsMessages $ getPsMessages pst
 #else
 #if MIN_VERSION_ghc(9,2,0)
                  bimap (fmap pprWarning) (fmap pprError) $
@@ -404,6 +410,15 @@ getMessages' pst dflags =
 #endif
 #endif
 
+renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg)
+renderMessages msgs =
+#if MIN_VERSION_ghc(9,3,0)
+  let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs
+  in (renderMsgs psWarnings, renderMsgs psErrors)
+#else
+  msgs
+#endif
+
 #if MIN_VERSION_ghc(9,2,0)
 pattern PFailedWithErrorMessages :: forall a b. (b -> Bag (MsgEnvelope DecoratedSDoc)) -> ParseResult a
 pattern PFailedWithErrorMessages msgs

ghcide/src/Development/IDE/GHC/Compat/Plugins.hs

@@ -35,15 +35,18 @@ import           Plugins
 import           Development.IDE.GHC.Compat.Core
 import           Development.IDE.GHC.Compat.Env    (hscSetFlags, hsc_dflags)
 import           Development.IDE.GHC.Compat.Parser as Parser
+import Debug.Trace
+import GHC.Driver.Env (hsc_plugins)
+import GHC.Driver.Plugins
 
-applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> IO ParsedSource
-applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do
+applyPluginsParsedResultAction :: HscEnv -> DynFlags -> ModSummary -> Parser.ApiAnns -> ParsedSource -> PsMessages -> IO (ParsedSource, PsMessages)
+applyPluginsParsedResultAction env dflags ms hpm_annotations parsed msgs = do
   -- Apply parsedResultAction of plugins
   let applyPluginAction p opts = parsedResultAction p opts ms
 #if MIN_VERSION_ghc(9,3,0)
-  fmap (hpm_module . parsedResultModule) $ runHsc env $ withPlugins
+  fmap (\result -> (hpm_module (parsedResultModule result), (parsedResultMessages result))) $ runHsc env $ withPlugins
 #else
-  fmap hpm_module $ runHsc env $ withPlugins
+  fmap ((, msgs), hpm_module) $ runHsc env $ withPlugins
 #endif
 #if MIN_VERSION_ghc(9,3,0)
       (Env.hsc_plugins env)
@@ -54,7 +57,7 @@ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed = do
 #endif
       applyPluginAction
 #if MIN_VERSION_ghc(9,3,0)
-      (ParsedResult (HsParsedModule parsed [] hpm_annotations) (PsMessages mempty mempty))
+      (ParsedResult (HsParsedModule parsed [] hpm_annotations) msgs)
 #else
       (HsParsedModule parsed [] hpm_annotations)
 #endif