Restore ability to run source plugins

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

@@ -171,11 +171,11 @@ typecheckModule :: IdeDefer
 typecheckModule (IdeDefer defer) hsc tc_helpers pm = do
         let modSummary = pm_mod_summary pm
             dflags = ms_hspp_opts modSummary
-        mmodSummary' <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"
+        initialized <- catchSrcErrors (hsc_dflags hsc) "typecheck (initialize plugins)"
                                       (initPlugins hsc modSummary)
-        case mmodSummary' of
+        case initialized of
           Left errs -> return (errs, Nothing)
-          Right modSummary' -> do
+          Right (modSummary', hsc) -> do
             (warnings, etcm) <- withWarnings "typecheck" $ \tweak ->
                 let
                   session = tweak (hscSetFlags dflags hsc)
@@ -472,7 +472,7 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
                     Nothing
 #endif
 
-#else 
+#else
   let !partial_iface = force (mkPartialIface session details simplified_guts)
   final_iface <- mkFullIface session partial_iface
 #endif
@@ -563,11 +563,6 @@ mkHiFileResultCompile se session' tcm simplified_guts = catchErrs $ do
       . (("Error during " ++ T.unpack source) ++) . show @SomeException
       ]
 
-initPlugins :: HscEnv -> ModSummary -> IO ModSummary
-initPlugins session modSummary = do
-    session1 <- liftIO $ initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session)
-    return modSummary{ms_hspp_opts = hsc_dflags session1}
-
 -- | Whether we should run the -O0 simplifier when generating core.
 --
 -- This is required for template Haskell to work but we disable this in DAML.
@@ -1095,7 +1090,9 @@ getModSummaryFromImports
   -> Maybe Util.StringBuffer
   -> ExceptT [FileDiagnostic] IO ModSummaryResult
 getModSummaryFromImports env fp modTime contents = do
-    (contents, opts, dflags) <- preprocessor env fp contents
+    (contents, opts, env) <- preprocessor env fp contents
+
+    let dflags = hsc_dflags env
 
     -- The warns will hopefully be reported when we actually parse the module
     (_warns, L main_loc hsmod) <- parseHeader dflags fp contents
@@ -1154,9 +1151,9 @@ getModSummaryFromImports env fp modTime contents = do
         then mkHomeModLocation dflags (pathToModuleName fp) fp
         else mkHomeModLocation dflags mod fp
 
-    let modl = mkHomeModule (hscHomeUnit (hscSetFlags dflags env)) mod
+    let modl = mkHomeModule (hscHomeUnit env) mod
         sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
-        msrModSummary =
+        msrModSummary2 =
             ModSummary
                 { ms_mod          = modl
                 , ms_hie_date     = Nothing
@@ -1181,7 +1178,8 @@ getModSummaryFromImports env fp modTime contents = do
                 , ms_textual_imps = textualImports
                 }
 
-    msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary
+    msrFingerprint <- liftIO $ computeFingerprint opts msrModSummary2
+    (msrModSummary, msrHscEnv) <- liftIO $ initPlugins env msrModSummary2
     return ModSummaryResult{..}
     where
         -- Compute a fingerprint from the contents of `ModSummary`,
@@ -1222,7 +1220,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 $ getPsMessages pst dflags
 
         -- Just because we got a `POk`, it doesn't mean there
         -- weren't errors! To clarify, the GHC parser
@@ -1257,9 +1255,18 @@ parseFileContents env customPreprocessor filename ms = do
      POk pst rdr_module ->
          let
              hpm_annotations = mkApiAnns pst
-             (warns, errs) = getMessages' pst dflags
+             psMessages = getPsMessages 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
@@ -1272,14 +1279,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/Core/Preprocessor.hs

@@ -36,30 +36,30 @@ import           GHC.Utils.Outputable              (renderWithContext)
 
 -- | Given a file and some contents, apply any necessary preprocessors,
 --   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
-preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], DynFlags)
-preprocessor env0 filename mbContents = do
+preprocessor :: HscEnv -> FilePath -> Maybe Util.StringBuffer -> ExceptT [FileDiagnostic] IO (Util.StringBuffer, [String], HscEnv)
+preprocessor env filename mbContents = do
     -- Perform unlit
     (isOnDisk, contents) <-
         if isLiterate filename then do
-            newcontent <- liftIO $ runLhs env0 filename mbContents
+            newcontent <- liftIO $ runLhs env filename mbContents
             return (False, newcontent)
         else do
             contents <- liftIO $ maybe (Util.hGetStringBuffer filename) return mbContents
             let isOnDisk = isNothing mbContents
             return (isOnDisk, contents)
 
     -- Perform cpp
-    (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env0 filename contents
-    let env1 = hscSetFlags dflags env0
-    let logger = hsc_logger env1
-    (isOnDisk, contents, opts, dflags) <-
+    (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents
+    let dflags = hsc_dflags env
+    let logger = hsc_logger env
+    (isOnDisk, contents, opts, env) <-
         if not $ xopt LangExt.Cpp dflags then
-            return (isOnDisk, contents, opts, dflags)
+            return (isOnDisk, contents, opts, env)
         else do
             cppLogs <- liftIO $ newIORef []
             let newLogger = pushLogHook (const (logActionCompat $ logAction cppLogs)) logger
             contents <- ExceptT
-                        $ (Right <$> (runCpp (putLogHook newLogger env1) filename
+                        $ (Right <$> (runCpp (putLogHook newLogger env) filename
                                        $ if isOnDisk then Nothing else Just contents))
                             `catch`
                             ( \(e :: Util.GhcException) -> do
@@ -68,16 +68,16 @@ preprocessor env0 filename mbContents = do
                                   []    -> throw e
                                   diags -> return $ Left diags
                             )
-            (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents
-            return (False, contents, opts, dflags)
+            (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents
+            return (False, contents, opts, env)
 
     -- Perform preprocessor
     if not $ gopt Opt_Pp dflags then
-        return (contents, opts, dflags)
+        return (contents, opts, env)
     else do
-        contents <- liftIO $ runPreprocessor env1 filename $ if isOnDisk then Nothing else Just contents
-        (opts, dflags) <- ExceptT $ parsePragmasIntoDynFlags env1 filename contents
-        return (contents, opts, dflags)
+        contents <- liftIO $ runPreprocessor env filename $ if isOnDisk then Nothing else Just contents
+        (opts, env) <- ExceptT $ parsePragmasIntoHscEnv env filename contents
+        return (contents, opts, env)
   where
     logAction :: IORef [CPPLog] -> LogActionCompat
     logAction cppLogs dflags _reason severity srcSpan _style msg = do
@@ -137,12 +137,12 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
 
 
 -- | This reads the pragma information directly from the provided buffer.
-parsePragmasIntoDynFlags
+parsePragmasIntoHscEnv
     :: HscEnv
     -> FilePath
     -> Util.StringBuffer
-    -> IO (Either [FileDiagnostic] ([String], DynFlags))
-parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do
+    -> IO (Either [FileDiagnostic] ([String], HscEnv))
+parsePragmasIntoHscEnv env fp contents = catchSrcErrors dflags0 "pragmas" $ do
 #if MIN_VERSION_ghc(9,3,0)
     let (_warns,opts) = getOptions (initParserOpts dflags0) contents fp
 #else
@@ -154,7 +154,7 @@ parsePragmasIntoDynFlags env fp contents = catchSrcErrors dflags0 "pragmas" $ do
 
     (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
     hsc_env' <- initializePlugins (hscSetFlags dflags env)
-    return (map unLoc opts, disableWarningsAsErrors (hsc_dflags hsc_env'))
+    return (map unLoc opts, hscSetFlags (disableWarningsAsErrors $ hsc_dflags hsc_env') hsc_env')
   where dflags0 = hsc_dflags env
 
 -- | Run (unlit) literate haskell preprocessor on a file, or buffer if set

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

@@ -155,7 +155,7 @@ data TcModuleResult = TcModuleResult
     , tmrTypechecked     :: TcGblEnv
     , tmrTopLevelSplices :: Splices
     -- ^ Typechecked splice information
-    , tmrDeferredError    :: !Bool
+    , tmrDeferredError   :: !Bool
     -- ^ Did we defer any type errors for this module?
     , tmrRuntimeModules  :: !(ModuleEnv ByteString)
         -- ^ Which modules did we need at runtime while compiling this file?
@@ -357,6 +357,12 @@ data ModSummaryResult = ModSummaryResult
   { msrModSummary  :: !ModSummary
   , msrImports     :: [LImportDecl GhcPs]
   , msrFingerprint :: !Fingerprint
+  , msrHscEnv      :: !HscEnv
+  -- ^ HscEnv for this particular ModSummary.
+  -- Contains initialised plugins, parsed options, etc...
+  --
+  -- Implicit assumption: DynFlags in 'msrModSummary' are the same as
+  -- the DynFlags in 'msrHscEnv'.
   }
 
 instance Show ModSummaryResult where

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

@@ -253,9 +253,7 @@ getParsedModuleRule :: Recorder (WithPriority Log) -> Rules ()
 getParsedModuleRule recorder =
   -- this rule does not have early cutoff since all its dependencies already have it
   define (cmapWithPrio LogShake recorder) $ \GetParsedModule file -> do
-    ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file
-    sess <- use_ GhcSession file
-    let hsc = hscEnv sess
+    ModSummaryResult{msrModSummary = ms', msrHscEnv = hsc} <- use_ GetModSummary file
     opt <- getIdeOptions
     modify_dflags <- getModifyDynFlags dynFlagsModifyParser
     let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }
@@ -327,16 +325,15 @@ getParsedModuleWithCommentsRule recorder =
   -- The parse diagnostics are owned by the GetParsedModule rule
   -- For this reason, this rule does not produce any diagnostics
   defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments file -> do
-    ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file
-    sess <- use_ GhcSession file
+    ModSummaryResult{msrModSummary = ms, msrHscEnv = hsc} <- use_ GetModSummary file
     opt <- getIdeOptions
 
     let ms' = withoutOption Opt_Haddock $ withOption Opt_KeepRawTokenStream ms
     modify_dflags <- getModifyDynFlags dynFlagsModifyParser
     let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }
         reset_ms pm = pm { pm_mod_summary = ms' }
 
-    liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition (hscEnv sess) opt file ms
+    liftIO $ fmap (fmap reset_ms) $ snd <$> getParsedModuleDefinition hsc opt file ms
 
 getModifyDynFlags :: (DynFlagsModifications -> a) -> Action a
 getModifyDynFlags f = do

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

@@ -25,7 +25,8 @@ module Development.IDE.GHC.Compat(
     disableWarningsAsErrors,
     reLoc,
     reLocA,
-    getMessages',
+    getPsMessages,
+    renderMessages,
     pattern PFailedWithErrorMessages,
     isObjectLinkable,
 
@@ -261,6 +262,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
 
 type ModIfaceAnnotation = Annotation
@@ -371,25 +373,13 @@ corePrepExpr _ = GHC.corePrepExpr
 simplifyExpr df _ = GHC.simplifyExpr df
 #endif
 
-#if MIN_VERSION_ghc(9,2,0)
-type ErrMsg  = MsgEnvelope DecoratedSDoc
-#endif
-#if MIN_VERSION_ghc(9,3,0)
-type WarnMsg  = MsgEnvelope DecoratedSDoc
-#endif
-
-getMessages' :: PState -> DynFlags -> (Bag WarnMsg, Bag ErrMsg)
-getMessages' pst dflags =
+renderMessages :: PsMessages -> (Bag WarnMsg, Bag ErrMsg)
+renderMessages msgs =
 #if MIN_VERSION_ghc(9,3,0)
-  bimap (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) (fmap (fmap renderDiagnosticMessageWithHints) . getMessages) $ getPsMessages pst
+  let renderMsgs extractor = (fmap . fmap) renderDiagnosticMessageWithHints . getMessages $ extractor msgs
+  in (renderMsgs psWarnings, renderMsgs psErrors)
 #else
-#if MIN_VERSION_ghc(9,2,0)
-                 bimap (fmap pprWarning) (fmap pprError) $
-#endif
-                 getMessages pst
-#if !MIN_VERSION_ghc(9,2,0)
-                   dflags
-#endif
+  msgs
 #endif
 
 #if MIN_VERSION_ghc(9,2,0)

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

@@ -579,7 +579,7 @@ import           GHC.Parser.Header            hiding (getImports)
 #if MIN_VERSION_ghc(9,2,0)
 import qualified GHC.Linker.Loader            as Linker
 import           GHC.Linker.Types
-import           GHC.Parser.Lexer             hiding (initParserState)
+import           GHC.Parser.Lexer             hiding (initParserState, getPsMessages)
 import           GHC.Parser.Annotation        (EpAnn (..))
 import           GHC.Platform.Ways
 import           GHC.Runtime.Context          (InteractiveImport (..))

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

@@ -27,6 +27,8 @@ module Development.IDE.GHC.Compat.Outputable (
     -- * Error infrastructure
     DecoratedSDoc,
     MsgEnvelope,
+    ErrMsg,
+    WarnMsg,
     errMsgSpan,
     errMsgSeverity,
     formatErrorWithQual,
@@ -192,6 +194,13 @@ type PsWarning = ErrMsg
 type PsError = ErrMsg
 #endif
 
+#if MIN_VERSION_ghc(9,2,0)
+type ErrMsg  = MsgEnvelope DecoratedSDoc
+#endif
+#if MIN_VERSION_ghc(9,3,0)
+type WarnMsg  = MsgEnvelope DecoratedSDoc
+#endif
+
 mkPrintUnqualifiedDefault :: HscEnv -> GlobalRdrEnv -> PrintUnqualified
 mkPrintUnqualifiedDefault env =
 #if MIN_VERSION_ghc(9,2,0)