Restore ability to run source plugins

JakobBruenker · JakobBruenker · commit b2ae93a950ed · 2022-10-30T22:09:09.000+01:00
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 and #2779.
diff --git a/ghcide/src/Development/IDE/Core/Compile.hs b/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
diff --git a/ghcide/src/Development/IDE/Core/Preprocessor.hs b/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
diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/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
diff --git a/ghcide/src/Development/IDE/GHC/Compat/Plugins.hs b/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)
