Restore ability to run source plugins

Since ghc 9.0, plugins are stored in the HscEnv, not in the DynFlags.
This caused HLS not to run source plugins anymore. This commit fixes
that.

Fixes #3299.

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

@@ -172,11 +172,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)
@@ -569,11 +569,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.
@@ -1101,7 +1096,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

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/Rules.hs

@@ -255,7 +255,7 @@ getParsedModuleRule recorder =
   define (cmapWithPrio LogShake recorder) $ \GetParsedModule file -> do
     ModSummaryResult{msrModSummary = ms'} <- use_ GetModSummary file
     sess <- use_ GhcSession file
-    let hsc = hscEnv sess
+    (ms', hsc) <- liftIO $ initPlugins (hscEnv sess) ms'
     opt <- getIdeOptions
     modify_dflags <- getModifyDynFlags dynFlagsModifyParser
     let ms = ms' { ms_hspp_opts = modify_dflags $ ms_hspp_opts ms' }
@@ -329,14 +329,15 @@ getParsedModuleWithCommentsRule recorder =
   defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \GetParsedModuleWithComments file -> do
     ModSummaryResult{msrModSummary = ms} <- use_ GetModSummary file
     sess <- use_ GhcSession file
+    (ms, hsc) <- liftIO $ initPlugins (hscEnv sess) ms
     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/Plugins.hs

@@ -7,6 +7,7 @@ module Development.IDE.GHC.Compat.Plugins (
     PluginWithArgs(..),
     applyPluginsParsedResultAction,
     initializePlugins,
+    initPlugins,
 
     -- * Static plugins
     StaticPlugin(..),
@@ -67,6 +68,12 @@ initializePlugins env = do
     pure $ hscSetFlags newDf env
 #endif
 
+-- Plugins aren't stored in ModSummary anymore since GHC 9.0, but this
+-- function still returns it for compatibility with 8.10
+initPlugins :: HscEnv -> ModSummary -> IO (ModSummary, HscEnv)
+initPlugins session modSummary = do
+    session1 <- initializePlugins (hscSetFlags (ms_hspp_opts modSummary) session)
+    return (modSummary{ms_hspp_opts = hsc_dflags session1}, session1)
 
 hsc_static_plugins :: HscEnv -> [StaticPlugin]
 #if MIN_VERSION_ghc(9,3,0)