From c844794d67f436de98f3608420fda8e9660d3b77 Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 31 Oct 2025 12:39:05 +0100 Subject: [PATCH 1/2] Add regression test for source plugins Demonstrates the issue #4631 --- ghcide-test/data/plugin-parser/cabal.project | 2 + .../data/plugin-parser/plugin/Plugin.hs | 37 +++++++ .../data/plugin-parser/plugin/plugin.cabal | 9 ++ ghcide-test/data/plugin-parser/usage/File1.hs | 6 ++ ghcide-test/data/plugin-parser/usage/File2.hs | 4 + .../data/plugin-parser/usage/usage.cabal | 10 ++ ghcide-test/exe/PluginSimpleTests.hs | 98 ++++++++++++------- 7 files changed, 133 insertions(+), 33 deletions(-) create mode 100644 ghcide-test/data/plugin-parser/cabal.project create mode 100644 ghcide-test/data/plugin-parser/plugin/Plugin.hs create mode 100644 ghcide-test/data/plugin-parser/plugin/plugin.cabal create mode 100644 ghcide-test/data/plugin-parser/usage/File1.hs create mode 100644 ghcide-test/data/plugin-parser/usage/File2.hs create mode 100644 ghcide-test/data/plugin-parser/usage/usage.cabal diff --git a/ghcide-test/data/plugin-parser/cabal.project b/ghcide-test/data/plugin-parser/cabal.project new file mode 100644 index 0000000000..55305b3916 --- /dev/null +++ b/ghcide-test/data/plugin-parser/cabal.project @@ -0,0 +1,2 @@ +packages: ./plugin + ./usage diff --git a/ghcide-test/data/plugin-parser/plugin/Plugin.hs b/ghcide-test/data/plugin-parser/plugin/Plugin.hs new file mode 100644 index 0000000000..d677a40b62 --- /dev/null +++ b/ghcide-test/data/plugin-parser/plugin/Plugin.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE RecordWildCards #-} +module Plugin (plugin) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.Foldable (for_) +import Data.List (foldl') +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Traversable (for) + +import qualified Data.Generics as SYB + +import qualified GHC.Plugins as GHC +import GHC + +plugin :: GHC.Plugin +plugin = GHC.defaultPlugin + { GHC.parsedResultAction = \_cliOptions -> pluginImpl + } + +pluginImpl :: GHC.ModSummary -> GHC.ParsedResult -> GHC.Hsc GHC.ParsedResult +pluginImpl _modSummary pm = do + let m = GHC.parsedResultModule pm + hpm_module' <- transform (GHC.hpm_module m) + let module' = m { GHC.hpm_module = hpm_module' } + return pm { GHC.parsedResultModule = module' } + +transform + :: GHC.Located (HsModule GhcPs) + -> GHC.Hsc (GHC.Located (HsModule GhcPs)) +transform = SYB.everywhereM (SYB.mkM transform') where + transform' :: LHsExpr GhcPs -> GHC.Hsc (LHsExpr GhcPs) + transform' expr@(L srcSpan (HsVar _ lvar)) = + if GHC.occNameString (GHC.occName $ GHC.unLoc lvar) == "pluginConstant" + then return (nlHsIntLit 0x42) + else return expr + transform' expr = + return expr diff --git a/ghcide-test/data/plugin-parser/plugin/plugin.cabal b/ghcide-test/data/plugin-parser/plugin/plugin.cabal new file mode 100644 index 0000000000..85a36c8a54 --- /dev/null +++ b/ghcide-test/data/plugin-parser/plugin/plugin.cabal @@ -0,0 +1,9 @@ +cabal-version: 1.18 +name: plugin +version: 1.0.0 +build-type: Simple + +library + build-depends: base, ghc, syb + exposed-modules: Plugin + hs-source-dirs: . diff --git a/ghcide-test/data/plugin-parser/usage/File1.hs b/ghcide-test/data/plugin-parser/usage/File1.hs new file mode 100644 index 0000000000..04a605ae6f --- /dev/null +++ b/ghcide-test/data/plugin-parser/usage/File1.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -Wall #-} +module File1 where + +import File2 + +bar = foo * foo diff --git a/ghcide-test/data/plugin-parser/usage/File2.hs b/ghcide-test/data/plugin-parser/usage/File2.hs new file mode 100644 index 0000000000..6440241b0b --- /dev/null +++ b/ghcide-test/data/plugin-parser/usage/File2.hs @@ -0,0 +1,4 @@ +module File2 where + +foo :: Int +foo = pluginConstant diff --git a/ghcide-test/data/plugin-parser/usage/usage.cabal b/ghcide-test/data/plugin-parser/usage/usage.cabal new file mode 100644 index 0000000000..2dd289562b --- /dev/null +++ b/ghcide-test/data/plugin-parser/usage/usage.cabal @@ -0,0 +1,10 @@ +cabal-version: 1.18 +name: usage +version: 1.0.0 +build-type: Simple + +library + build-depends: base, plugin + exposed-modules: File1 File2 + ghc-options: -fplugin Plugin + hs-source-dirs: . diff --git a/ghcide-test/exe/PluginSimpleTests.hs b/ghcide-test/exe/PluginSimpleTests.hs index b15e9af749..1a5516f980 100644 --- a/ghcide-test/exe/PluginSimpleTests.hs +++ b/ghcide-test/exe/PluginSimpleTests.hs @@ -2,7 +2,6 @@ module PluginSimpleTests (tests) where import Config -import Control.Monad.IO.Class (liftIO) import Development.IDE.Test (expectDiagnostics) import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), SemanticTokenRelative (..), @@ -11,37 +10,70 @@ import Language.LSP.Test import System.FilePath import Test.Hls.FileSystem import Test.Tasty +import qualified Test.Hls.FileSystem as FS tests :: TestTree -tests = - -- Build profile: -w ghc-9.4.2 -O1 - -- In order, the following will be built (use -v for more details): - -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) - -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build) - -- - plugin-1.0.0 (lib) (first run) - -- Starting ghc-typelits-natnormalise-0.7.7 (lib) - -- Building ghc-typelits-natnormalise-0.7.7 (lib) - - -- Failed to build ghc-typelits-natnormalise-0.7.7. - -- Build log ( - -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log - -- ): - -- Preprocessing library for ghc-typelits-natnormalise-0.7.7.. - -- Building library for ghc-typelits-natnormalise-0.7.7.. - -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o ) - -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o ) - -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o ) - -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory - - -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is - -- required by plugin-1.0.0). See the build log above for details. - testWithExtraFiles "simple plugin" "plugin-knownnat" $ \dir -> do - _ <- openDoc (dir "KnownNat.hs") "haskell" - liftIO $ atomicFileWriteString (dir"hie.yaml") - "cradle: {cabal: [{path: '.', component: 'lib:plugin'}]}" - - expectDiagnostics - [ ( "KnownNat.hs", - [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c", Just "GHC-88464")] - ) - ] +tests = testGroup "ghc-plugins" + [ + -- Build profile: -w ghc-9.4.2 -O1 + -- In order, the following will be built (use -v for more details): + -- - ghc-typelits-natnormalise-0.7.7 (lib) (requires build) + -- - ghc-typelits-knownnat-0.7.7 (lib) (requires build) + -- - plugin-1.0.0 (lib) (first run) + -- Starting ghc-typelits-natnormalise-0.7.7 (lib) + -- Building ghc-typelits-natnormalise-0.7.7 (lib) + + -- Failed to build ghc-typelits-natnormalise-0.7.7. + -- Build log ( + -- C:\cabal\logs\ghc-9.4.2\ghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.log + -- ): + -- Preprocessing library for ghc-typelits-natnormalise-0.7.7.. + -- Building library for ghc-typelits-natnormalise-0.7.7.. + -- [1 of 3] Compiling GHC.TypeLits.Normalise.SOP ( src\GHC\TypeLits\Normalise\SOP.hs, dist\build\GHC\TypeLits\Normalise\SOP.o ) + -- [2 of 3] Compiling GHC.TypeLits.Normalise.Unify ( src\GHC\TypeLits\Normalise\Unify.hs, dist\build\GHC\TypeLits\Normalise\Unify.o ) + -- [3 of 3] Compiling GHC.TypeLits.Normalise ( src-ghc-9.4\GHC\TypeLits\Normalise.hs, dist\build\GHC\TypeLits\Normalise.o ) + -- C:\tools\ghc-9.4.2\lib\../mingw/bin/llvm-ar.exe: error: dist\build\objs-5156\libHSghc-typelits-_-0.7.7-3f036a52a0d9bfc3389d1852a87da2e87c6de2e4.a: No such file or directory + + -- Error: cabal: Failed to build ghc-typelits-natnormalise-0.7.7 (which is + -- required by plugin-1.0.0). See the build log above for details. + testWithDummyPlugin "simple plugin" pluginKnownNatVfs $ do + _ <- openDoc "KnownNat.hs" "haskell" + + expectDiagnostics + [ ( "KnownNat.hs", + [(DiagnosticSeverity_Error, (9, 15), "Variable not in scope: c", Just "GHC-88464")] + ) + ] + , testWithDummyPlugin "simple parser plugin" pluginParsreVfs $ do + _ <- openDoc "usage/File1.hs" "haskell" + + expectDiagnostics + [ ( ("usage" "File1.hs"), + [(DiagnosticSeverity_Warning, (5, 0), "Top-level binding with no type signature: bar :: Int", Just "GHC-38417")] + ) + ] + ] + +pluginKnownNatVfs :: VirtualFileTree +pluginKnownNatVfs = FS.mkVirtualFileTree ("ghcide-test" "data" "plugin-knownnat") $ + FS.simpleCabalProject + [ "cabal.project" + , "KnownNat.hs" + , "plugin.cabal" + ] + +pluginParsreVfs :: VirtualFileTree +pluginParsreVfs = FS.mkVirtualFileTree ("ghcide-test" "data" "plugin-parser") $ + [ simpleCabalCradle + , copy "cabal.project" + , directory "plugin" + [ copy "plugin/Plugin.hs" + , copy "plugin/plugin.cabal" + ] + , directory "usage" + [ copy "usage/File1.hs" + , copy "usage/File2.hs" + , copy "usage/usage.cabal" + ] + ] + From 695673a325ebd8e51d553215ce40cb8bdf2c25cc Mon Sep 17 00:00:00 2001 From: fendor Date: Fri, 31 Oct 2025 12:40:11 +0100 Subject: [PATCH 2/2] Use the HscEnv after processing the ModSummary Makes sure we don't use the initialised plugins. Fixes #4631. --- ghcide/src/Development/IDE/Core/Rules.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index daaa28c5da..1e050d57b1 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -744,18 +744,20 @@ ghcSessionDepsDefinition :: -- | full mod summary Bool -> GhcSessionDepsConfig -> HscEnvEq -> NormalizedFilePath -> Action (Maybe HscEnvEq) -ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do - let hsc = hscEnv env - +ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} hscEnvEq file = do mbdeps <- mapM(fmap artifactFilePath . snd) <$> use_ GetLocatedImports file case mbdeps of Nothing -> return Nothing Just deps -> do when fullModuleGraph $ void $ use_ ReportImportCycles file - ms <- msrModSummary <$> if fullModSummary + msr <- if fullModSummary then use_ GetModSummary file else use_ GetModSummaryWithoutTimestamps file - + let + ms = msrModSummary msr + -- This `HscEnv` has its plugins initialized in `parsePragmasIntoHscEnv` + -- Fixes the bug in #4631 + env = msrHscEnv msr depSessions <- map hscEnv <$> uses_ (GhcSessionDeps_ fullModSummary) deps ifaces <- uses_ GetModIface deps let inLoadOrder = map (\HiFileResult{..} -> HomeModInfo hirModIface hirModDetails emptyHomeModInfoLinkable) ifaces @@ -775,14 +777,14 @@ ghcSessionDepsDefinition fullModSummary GhcSessionDepsConfig{..} env file = do nubOrdOn mkNodeKey (ModuleNode final_deps ms : concatMap mgModSummaries' mgs) liftIO $ evaluate $ liftRnf rwhnf module_graph_nodes return $ mkModuleGraph module_graph_nodes - session' <- liftIO $ mergeEnvs hsc mg de ms inLoadOrder depSessions + session' <- liftIO $ mergeEnvs env mg de ms inLoadOrder depSessions -- Here we avoid a call to to `newHscEnvEqWithImportPaths`, which creates a new -- ExportsMap when it is called. We only need to create the ExportsMap once per -- session, while `ghcSessionDepsDefinition` will be called for each file we need -- to compile. `updateHscEnvEq` will refresh the HscEnv (session') and also -- generate a new Unique. - Just <$> liftIO (updateHscEnvEq env session') + Just <$> liftIO (updateHscEnvEq hscEnvEq session') -- | Load a iface from disk, or generate it if there isn't one or it is out of date -- This rule also ensures that the `.hie` and `.o` (if needed) files are written out.