Never compute the DocMap with stale data

.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:

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

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

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

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

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"
+               ]

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 $ getHover cdoc (hoverOnMyMethod brokenC)
+    void $ waitForDiagnosticsFrom cdoc  -- let the broken state settle
+    -- 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'"

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 <> ":<LINE>:<COL>**[...]", 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

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 ("[...]<FILE_NAME>:<LINE>:<COL>**[...]", 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"]

ghcide-test/exe/Main.hs

@@ -44,6 +44,7 @@ import           CPPTests
 import           CradleTests
 import           DependentFileTest
 import           DiagnosticTests
+import           EpsPollutionTests
 import           ExceptionTests
 import           FindDefinitionAndHoverTests
 import           FindImplementationAndHoverTests
@@ -94,6 +95,7 @@ main = do
     , WatchedFileTests.tests
     , CradleTests.tests
     , DependentFileTest.tests
+    , EpsPollutionTests.tests
     , NonLspCommandLine.tests
     , IfaceTests.tests
     , BootTests.tests