diff --git a/.hlint.yaml b/.hlint.yaml index 47ff194257..adc3e992d7 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -161,8 +161,7 @@ - Ide.PluginUtils - Ide.Plugin.Eval.Parse.Comments - Ide.Plugin.Eval.CodeLens - - FindDefinitionAndHoverTests #Previously part of GHCIDE Main tests - - FindImplementationAndHoverTests #Previously part of GHCIDE Main tests + - Hover #Used for tests that are allowed to crash - name: [Prelude.init, Data.List.init] within: diff --git a/ghcide-test/data/multi-unit-eps-pollution/a-1.0.0-inplace b/ghcide-test/data/multi-unit-eps-pollution/a-1.0.0-inplace new file mode 100644 index 0000000000..a0007aa405 --- /dev/null +++ b/ghcide-test/data/multi-unit-eps-pollution/a-1.0.0-inplace @@ -0,0 +1,8 @@ +-i +-ia +-this-unit-id +a-1.0.0-inplace +-package +base +-XHaskell2010 +A diff --git a/ghcide-test/data/multi-unit-eps-pollution/a/A.hs b/ghcide-test/data/multi-unit-eps-pollution/a/A.hs new file mode 100644 index 0000000000..55cda9e0cc --- /dev/null +++ b/ghcide-test/data/multi-unit-eps-pollution/a/A.hs @@ -0,0 +1,9 @@ +module A (AType, MyClass(..)) where + +data AType = AType Int + +class MyClass a where + myMethod :: a -> String + +instance MyClass AType where + myMethod (AType n) = "AType " ++ show n diff --git a/ghcide-test/data/multi-unit-eps-pollution/c-1.0.0-inplace b/ghcide-test/data/multi-unit-eps-pollution/c-1.0.0-inplace new file mode 100644 index 0000000000..18227e0b5a --- /dev/null +++ b/ghcide-test/data/multi-unit-eps-pollution/c-1.0.0-inplace @@ -0,0 +1,9 @@ +-i +-ic +-this-unit-id +c-1.0.0-inplace +-package-id +a-1.0.0-inplace +-package +base +C diff --git a/ghcide-test/data/multi-unit-eps-pollution/c/C.hs b/ghcide-test/data/multi-unit-eps-pollution/c/C.hs new file mode 100644 index 0000000000..30653e4d40 --- /dev/null +++ b/ghcide-test/data/multi-unit-eps-pollution/c/C.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wall #-} +module C where +import A + +-- Omit top-level signature so we have a warning we can check against +cFoo = myMethod @AType diff --git a/ghcide-test/data/multi-unit-eps-pollution/hie.yaml b/ghcide-test/data/multi-unit-eps-pollution/hie.yaml new file mode 100644 index 0000000000..84a50fcf94 --- /dev/null +++ b/ghcide-test/data/multi-unit-eps-pollution/hie.yaml @@ -0,0 +1,5 @@ +cradle: + direct: + arguments: ["-unit" ,"@a-1.0.0-inplace" + ,"-unit" ,"@c-1.0.0-inplace" + ] diff --git a/ghcide-test/exe/EpsPollutionTests.hs b/ghcide-test/exe/EpsPollutionTests.hs new file mode 100644 index 0000000000..97156c3e81 --- /dev/null +++ b/ghcide-test/exe/EpsPollutionTests.hs @@ -0,0 +1,98 @@ +-- | Regression test: edits that break typechecking can leave HLS's +-- shared 'ExternalPackageState' ('EPS') polluted with interfaces and +-- instances from /home-package/ modules. The next successful typecheck +-- of a module that also legitimately has those home modules in its HPT +-- reports \"Overlapping instance\" with both matches pointing at the +-- same source location, because 'tcGetInstEnvs' returns the same +-- 'ClsInst' twice (once via @ie_global@ from the EPS, once via +-- @ie_local@ from 'hptInstancesBelow'). +-- +-- The pollution entered through 'Development.IDE.Spans.Documentation.mkDocMap'. +-- Its 'Rules.GetDocMap' rule read three inputs via independent +-- @useWithStale_@ calls: 'TypeCheck', 'GhcSessionDeps' and 'GetHieAst'. +-- These three can diverge: an edit that merely changes imports lets +-- 'GhcSessionDeps' re-evaluate (fresh, with a different HPT) while +-- 'TypeCheck' and 'GetHieAst' fall back to their last-successful values. +-- If the stale 'RefMap' references a name whose module is no longer in +-- the fresh HPT, 'mkDocMap' asks 'getDocsBatch' for its docs; +-- 'loadSysInterface' does not find the module in the HUG and calls +-- 'loadInterface', which puts the home-module interface -- /with its +-- instance environment/ -- into the shared EPS @IORef@. The EPS never +-- evicts anything, so the pollution is permanent for the session. +module EpsPollutionTests (tests) where + +import Config (Expect (ExpectHoverText), + runWithExtraFiles) +import Control.Lens ((^.)) +import Control.Monad (void) +import qualified Data.Text as T +import Development.IDE.GHC.Util (readFileUtf8) +import Hover +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types +import Language.LSP.Test +import System.FilePath +import Test.Hls + +tests :: TestTree +tests = testGroup "eps-pollution" + [ staleHieProvokesOverlapping + ] + +-- The fixture at ghcide-test/data/multi-unit-eps-pollution/ sets up two +-- home units: unit @a@ provides module @A@ which defines @MyClass@ and +-- @instance MyClass AType@; unit @c@ provides module @C@ which imports +-- @A@ and uses @myMethod@ on an @AType@ value (forcing instance +-- resolution). + +staleHieProvokesOverlapping :: TestTree +staleHieProvokesOverlapping = + testCase "Stale RefMap must not provoke overlapping-instance error" $ + runWithExtraFiles "multi-unit-eps-pollution" $ \dir -> do + let cPath = dir "c" "C.hs" + originalC <- liftIO $ readFileUtf8 cPath + let brokenC = T.replace "import A\n" "" originalC + cdoc <- openDoc cPath "haskell" + void $ waitForTypecheck cdoc + -- Hovering triggers the hover pipeline, which forces GetDocMap. + -- While C is healthy this populates GetHieAst with a RefMap + -- referencing A's names -- the stale value we rely on below. + hover <- getHover cdoc (hoverOnMyMethod originalC) + checkHover hover [ExpectHoverText ["myMethod", "MyClass"]] + + -- Break C's import of A. C fails to typecheck, but GhcSessionDeps + -- re-evaluates successfully (it only needs the import list) with an + -- HPT that no longer contains A. A further hover forces GetDocMap + -- to run with the fresh GhcSessionDeps alongside the stale RefMap; + -- loadSysInterface(A) then runs and pollutes the EPS. + changeDoc cdoc [TextDocumentContentChangeEvent . InR . + TextDocumentContentChangeWholeDocument $ brokenC] + void $ waitForDiagnosticsFrom cdoc + void $ getHover cdoc (hoverOnMyMethod brokenC) + -- Repair C. The next typecheck legitimately has A in its HPT; with + -- the polluted EPS it also has A's ClsInst in eps_inst_env, so + -- instance resolution for 'myMethod x :: AType -> String' finds + -- two matches with identical source locations. + changeDoc cdoc [TextDocumentContentChangeEvent . InR . + TextDocumentContentChangeWholeDocument $ originalC] + diags <- waitForDiagnosticsFrom cdoc + liftIO $ assertBool + ("Expected no overlapping-instance errors, got diagnostics:\n" + ++ unlines (map (T.unpack . (^. L.message)) diags)) + (not (any isOverlappingInstance diags)) + where + isOverlappingInstance d = + "Overlapping instance" `T.isInfixOf` (d ^. L.message) + +-- | 'Position' at the first occurrence of @myMethod@ in the given source. +-- Computed rather than hard-coded because the broken variant has one +-- fewer line than the original. +hoverOnMyMethod :: T.Text -> Position +hoverOnMyMethod src = + case [ Position row (fromIntegral (T.length prefix)) + | (row, line) <- zip [0..] (T.lines src) + , let (prefix, rest) = T.breakOn "myMethod" line + , not (T.null rest) + ] of + p : _ -> p + [] -> error "hoverOnMyMethod: no occurrence of 'myMethod'" diff --git a/ghcide-test/exe/FindDefinitionAndHoverTests.hs b/ghcide-test/exe/FindDefinitionAndHoverTests.hs index d97d340029..6ad8a759a1 100644 --- a/ghcide-test/exe/FindDefinitionAndHoverTests.hs +++ b/ghcide-test/exe/FindDefinitionAndHoverTests.hs @@ -1,27 +1,20 @@ {-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module FindDefinitionAndHoverTests (tests) where -import Control.Monad -import Data.Foldable +import Config +import Control.Lens ((^.)) import Data.Maybe import qualified Data.Text as T +import Development.IDE.Test (expectDiagnostics) +import Hover import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Test import System.Info.Extra (isWindows) - -import Config -import Control.Category ((>>>)) -import Control.Lens ((^.)) -import Development.IDE.Test (expectDiagnostics, - standardizeQuotes) -import Hover -import Ide.Types (Config (..), OptLinkTo (..)) +import Ide.Types import Test.Hls import Test.Hls.FileSystem (copyDir) -import Text.Regex.TDFA ((=~)) tests :: TestTree tests = let @@ -35,64 +28,6 @@ tests = let check found targetRange - - checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session () - checkHover hover expectations = traverse_ check =<< expectations where - - check :: (HasCallStack) => Expect -> Session () - check expected = - case hover of - Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" - Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = rangeInHover } -> - case expected of - ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg - ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets - ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets - ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) - ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover - _ -> pure () -- all other expectations not relevant to hover - _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover - - extractLineColFromHoverMsg :: T.Text -> [T.Text] - extractLineColFromHoverMsg = - -- Hover messages contain multiple lines, and we are looking for the definition - -- site - T.lines - -- The line we are looking for looks like: "*Defined at /tmp/GotoHover.hs:22:3*" - -- So filter by the start of the line - >>> mapMaybe (T.stripPrefix "*Defined at") - -- There can be multiple definitions per hover message! - -- See the test "field in record definition" for example. - -- The tests check against the last line that contains the above line. - >>> last - -- [" /tmp/", "22:3*"] - >>> T.splitOn (sourceFileName <> ":") - -- "22:3*" - >>> last - -- ["22:3", ""] - >>> T.splitOn "*" - -- "22:3" - >>> head - -- ["22", "3"] - >>> T.splitOn ":" - - checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () - checkHoverRange expectedRange rangeInHover msg = - let - lineCol = extractLineColFromHoverMsg msg - -- looks like hovers use 1-based numbering while definitions use 0-based - -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. - adjust Position{_line = l, _character = c} = - Position{_line = l + 1, _character = c + 1} - in - case map (read . T.unpack) lineCol of - [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c - _ -> liftIO $ assertFailure $ - "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> - "\n but got: " <> show (msg, rangeInHover) - sourceFilePath = T.unpack sourceFileName sourceFileName = "GotoHover.hs" @@ -113,9 +48,9 @@ tests = let , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] recordDotSyntaxTests = - [ tst (getHover, checkHover) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" - , tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" - , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" + [ tst (getHover, checkHoverM) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" + , tst (getHover, checkHoverM) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" + , tst (getHover, checkHoverM) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" ] test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) @@ -131,7 +66,7 @@ tests = let ( runDef $ tst def look sourceFilePath expect title , runHover $ tst hover look sourceFilePath expect title ) where def = (getDefinitions, checkDefs) - hover = (getHover , checkHover) + hover = (getHover , checkHoverM) -- search locations expectations on results -- TODO: Lookup of record field should return exactly one result diff --git a/ghcide-test/exe/Hover.hs b/ghcide-test/exe/Hover.hs index 17b3f9c86a..0daf3f4cb0 100644 --- a/ghcide-test/exe/Hover.hs +++ b/ghcide-test/exe/Hover.hs @@ -1,10 +1,19 @@ -module Hover where +module Hover ( + assertFoundIn, + assertNotFoundIn, + checkHover, + checkHoverM, +) where import Config +import Control.Arrow +import Control.Lens import Control.Monad import Data.Foldable -import qualified Data.Text as T +import Data.Maybe (mapMaybe) +import qualified Data.Text as T import Development.IDE.Test +import qualified Language.LSP.Protocol.Lens as L import Test.Hls import Text.Regex.TDFA @@ -21,20 +30,79 @@ assertNotFoundIn part whole = (not . T.isInfixOf part $ whole) checkHover :: (HasCallStack) => Maybe Hover -> [Expect] -> Session () -checkHover hover expectations = traverse_ check expectations +checkHover hover expectations = checkHoverM hover (pure expectations) + +checkHoverM :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session () +checkHoverM hover expectations = + traverse_ check =<< expectations where check :: (HasCallStack) => Expect -> Session () check expected = case hover of Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) - ,_range = _rangeInHover } -> + ,_range = rangeInHover } -> case expected of - ExpectRange _expectedRange -> liftIO $ assertFailure $ "ExpectRange assertion not implemented, yet." - ExpectHoverRange _expectedRange -> liftIO $ assertFailure $ "ExpectHoverRange assertion not implemented, yet." + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover _ -> pure () -- all other expectations not relevant to hover _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + +-- | Extract the source position from a message such as +-- +-- @ +-- "*Defined at C://file-name.hs:22:3*" +-- @ +-- +-- >>> extractLineColFromHoverMsg "*Defined at C://tmp/GotoHover.hs:22:3*" +-- ["22","3"] +-- +-- >>> extractLineColFromHoverMsg "*Defined at /tmp/GotoHover.hs:22:3*" +-- ["22","3"] +extractLineColFromHoverMsg :: T.Text -> [T.Text] +extractLineColFromHoverMsg = + -- Windows: "*Defined at C://tmp/GotoHover.hs:22:3*" + -- Linux: "*Defined at /tmp/GotoHover.hs:22:3*" + T.lines + -- Windows: ["*Defined at C://tmp/GotoHover.hs:22:3*"] + -- Linux: ["*Defined at /tmp/GotoHover.hs:22:3*"] + >>> mapMaybe (T.stripPrefix "*Defined at ") + -- Windows: ["C://tmp/GotoHover.hs:22:3*"] + -- Linux: ["/tmp/GotoHover.hs:22:3*"] + >>> last + -- Windows: "C://tmp/GotoHover.hs:22:3*" + -- Linux: "/tmp/GotoHover.hs:22:3*" + >>> T.dropEnd 1 + -- Windows: "C://tmp/GotoHover.hs:22:3" + -- Linux: "/tmp/GotoHover.hs:22:3" + >>> T.splitOn ":" + -- Windows: ["C", "//tmp/GotoHover.hs", "22", "3"] + -- Linux: ["/tmp/GotoHover.hs", "22", "3"] + >>> reverse + -- Windows: ["3", "22", "//tmp/GotoHover.hs", "C"] + -- Linux: ["3", "22", "/tmp/GotoHover.hs"] + >>> take 2 + -- Windows: ["3", "22"] + -- Linux: ["3", "22"] + >>> reverse + -- Windows: ["22", "3"] + -- Linux: ["22", "3"] diff --git a/ghcide-test/exe/Main.hs b/ghcide-test/exe/Main.hs index 4edb4b022b..2ab0631ce7 100644 --- a/ghcide-test/exe/Main.hs +++ b/ghcide-test/exe/Main.hs @@ -45,6 +45,7 @@ import CPPTests import CradleTests import DependentFileTest import DiagnosticTests +import EpsPollutionTests import ExceptionTests import FindDefinitionAndHoverTests import FindImplementationAndHoverTests @@ -95,6 +96,7 @@ main = do , WatchedFileTests.tests , CradleTests.tests , DependentFileTest.tests + , EpsPollutionTests.tests , NonLspCommandLine.tests , IfaceTests.tests , BootTests.tests diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 24de344bfa..9ae8ee370c 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -579,11 +579,9 @@ getBindingsRule recorder = getDocMapRule :: Recorder (WithPriority Log) -> Rules () getDocMapRule recorder = define (cmapWithPrio LogShake recorder) $ \GetDocMap file -> do - -- Stale data for the scenario where a broken module has previously typechecked - -- but we never generated a DocMap for it - (tmrTypechecked -> tc, _) <- useWithStale_ TypeCheck file - (hscEnv -> hsc, _) <- useWithStale_ GhcSessionDeps file - (HAR{refMap=rf}, _) <- useWithStale_ GetHieAst file + (tmrTypechecked -> tc) <- use_ TypeCheck file + (hscEnv -> hsc) <- use_ GhcSessionDeps file + HAR{refMap=rf} <- use_ GetHieAst file cfg <- getClientConfigAction dkMap <- liftIO $ mkDocMap hsc rf tc $ LinkTargets { linkSource = linkSourceTo cfg diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index 569225e999..0da5d200f1 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -2079,6 +2079,7 @@ test-suite ghcide-tests CradleTests DependentFileTest DiagnosticTests + EpsPollutionTests ExceptionTests FindDefinitionAndHoverTests FindImplementationAndHoverTests