Deduplicate module not found diagnostics (#952)

* Trace rule errors

* Disable check parents in command line script

* Fix expectDiagnostics []

* Add a test

* remove uses of stale info within rules

The use of stale information should be limited to the leaves of the processing
tree, otherwise it becomes impossible to reason about the semantics of diagnostics

* Use stale info in the NeedsCompilation rule

* Use stale data in GetDocMap

* Fix tests that relied on unsupported behaviour of expectDiagnostics

exe/Main.hs

@@ -150,6 +150,8 @@ main = do
                     -- , optOTMemoryProfiling = IdeOTMemoryProfiling argsOTMemoryProfiling
                     , optTesting           = IdeTesting argsTesting
                     , optThreads           = argsThreads
+                    , optCheckParents      = NeverCheck
+                    , optCheckProject      = CheckProject False
                     }
             logLevel = if argsVerbose then minBound else Info
         ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) dummyWithProg (const (const id)) (logger logLevel) debouncer options vfs

src/Development/IDE/Core/Rules.hs

@@ -553,16 +553,18 @@ getBindingsRule =
 getDocMapRule :: Rules ()
 getDocMapRule =
     define $ \GetDocMap file -> do
-      (tmrTypechecked -> tc,_) <- useWithStale_ TypeCheck file
-      (hscEnv -> hsc,_) <-useWithStale_ GhcSessionDeps file
-      (refMap -> rf, _) <- useWithStale_ GetHieAst file
+      -- 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
+      (refMap -> rf, _)         <- useWithStale_ GetHieAst file
 
 -- When possible, rely on the haddocks embedded in our interface files
 -- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
 #if !defined(GHC_LIB)
       let parsedDeps = []
 #else
-      deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
+      deps <- fromMaybe (TransitiveDependencies [] [] []) <$> use GetDependencies file
       let tdeps = transitiveModuleDeps deps
       parsedDeps <- uses_ GetParsedModule tdeps
 #endif
@@ -664,8 +666,8 @@ ghcSessionDepsDefinition :: NormalizedFilePath -> Action (IdeResult HscEnvEq)
 ghcSessionDepsDefinition file = do
         env <- use_ GhcSession file
         let hsc = hscEnv env
-        ((ms,_),_) <- useWithStale_ GetModSummaryWithoutTimestamps file
-        (deps,_) <- useWithStale_ GetDependencies file
+        (ms,_) <- use_ GetModSummaryWithoutTimestamps file
+        deps <- use_ GetDependencies file
         let tdeps = transitiveModuleDeps deps
             uses_th_qq =
               xopt LangExt.TemplateHaskell dflags || xopt LangExt.QuasiQuotes dflags
@@ -894,7 +896,15 @@ getLinkableType f = do
 
 needsCompilationRule :: Rules ()
 needsCompilationRule = defineEarlyCutoff $ \NeedsCompilation file -> do
-  ((ms,_),_) <- useWithStale_ GetModSummaryWithoutTimestamps file
+  -- It's important to use stale data here to avoid wasted work.
+  -- if NeedsCompilation fails for a module M its result will be  under-approximated
+  -- to False in its dependencies. However, if M actually used TH, this will
+  -- cause a re-evaluation of GetModIface for all dependencies
+  -- (since we don't need to generate object code anymore).
+  -- Once M is fixed we will discover that we actually needed all the object code
+  -- that we just threw away, and thus have to recompile all dependencies once
+  -- again, this time keeping the object code.
+  (ms,_) <- fst <$> useWithStale_ GetModSummaryWithoutTimestamps file
   -- A file needs object code if it uses TemplateHaskell or any file that depends on it uses TemplateHaskell
   res <-
     if uses_th_qq ms

src/Development/IDE/Core/Shake.hs

@@ -830,7 +830,7 @@ defineEarlyCutoff
     :: IdeRule k v
     => (k -> NormalizedFilePath -> Action (Maybe BS.ByteString, IdeResult v))
     -> Rules ()
-defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file $ do
+defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old :: Maybe BS.ByteString) mode -> otTracedAction key file isSuccess $ do
     extras@ShakeExtras{state, inProgress} <- getShakeExtras
     -- don't do progress for GetFileExists, as there are lots of non-nodes for just that one key
     (if show key == "GetFileExists" then id else withProgressVar inProgress file) $ do
@@ -880,8 +880,9 @@ defineEarlyCutoff op = addBuiltinRule noLint noIdentity $ \(Q (key, file)) (old
         -- least 1000 modifications.
         where f shift = modifyVar_ var $ \x -> evaluate $ HMap.insertWith (\_ x -> shift x) file (shift 0) x
 
-
-
+isSuccess :: RunResult (A v) -> Bool
+isSuccess (RunResult _ _ (A Failed)) = False
+isSuccess _ = True
 
 -- | Rule type, input file
 data QDisk k = QDisk k NormalizedFilePath

src/Development/IDE/Core/Tracing.hs

@@ -13,7 +13,7 @@ import           Control.Concurrent.Extra       (Var, modifyVar_, newVar,
                                                  readVar, threadDelay)
 import           Control.Exception              (evaluate)
 import           Control.Exception.Safe         (catch, SomeException)
-import           Control.Monad                  (forM_, forever, (>=>))
+import           Control.Monad                  (unless, forM_, forever, (>=>))
 import           Control.Monad.Extra            (whenJust)
 import           Control.Seq                    (r0, seqList, seqTuple2, using)
 import           Data.Dynamic                   (Dynamic)
@@ -56,16 +56,20 @@ otTracedAction
     :: Show k
     => k -- ^ The Action's Key
     -> NormalizedFilePath -- ^ Path to the file the action was run for
+    -> (a -> Bool) -- ^ Did this action succeed?
     -> Action a -- ^ The action
     -> Action a
-otTracedAction key file act = actionBracket
+otTracedAction key file success act = actionBracket
     (do
         sp <- beginSpan (fromString (show key))
         setTag sp "File" (fromString $ fromNormalizedFilePath file)
         return sp
     )
     endSpan
-    (const act)
+    (\sp -> do
+        res <- act
+        unless (success res) $ setTag sp "error" "1"
+        return res)
 
 startTelemetry :: Logger -> Var Values -> IO ()
 startTelemetry logger stateRef = do

test/exe/Main.hs

@@ -323,8 +323,11 @@ diagnosticTests = testGroup "diagnostics"
             , "import {-# SOURCE #-} ModuleB"
             ]
       let contentB = T.unlines
-            [ "module ModuleB where"
+            [ "{-# OPTIONS -Wmissing-signatures#-}"
+            , "module ModuleB where"
             , "import ModuleA"
+            -- introduce an artificial diagnostic
+            , "foo = ()"
             ]
       let contentBboot = T.unlines
             [ "module ModuleB where"
@@ -332,7 +335,7 @@ diagnosticTests = testGroup "diagnostics"
       _ <- createDoc "ModuleA.hs" "haskell" contentA
       _ <- createDoc "ModuleB.hs" "haskell" contentB
       _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot
-      expectDiagnostics []
+      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]
   , testSessionWait "correct reference used with hs-boot" $ do
       let contentB = T.unlines
             [ "module ModuleB where"
@@ -347,7 +350,8 @@ diagnosticTests = testGroup "diagnostics"
             [ "module ModuleA where"
             ]
       let contentC = T.unlines
-            [ "module ModuleC where"
+            [ "{-# OPTIONS -Wmissing-signatures #-}"
+            , "module ModuleC where"
             , "import ModuleA"
             -- this reference will fail if it gets incorrectly
             -- resolved to the hs-boot file
@@ -357,7 +361,7 @@ diagnosticTests = testGroup "diagnostics"
       _ <- createDoc "ModuleA.hs" "haskell" contentA
       _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot
       _ <- createDoc "ModuleC.hs" "haskell" contentC
-      expectDiagnostics []
+      expectDiagnostics [("ModuleC.hs", [(DsWarning, (3,0), "Top-level binding")])]
   , testSessionWait "redundant import" $ do
       let contentA = T.unlines ["module ModuleA where"]
       let contentB = T.unlines
@@ -375,13 +379,15 @@ diagnosticTests = testGroup "diagnostics"
   , testSessionWait "redundant import even without warning" $ do
       let contentA = T.unlines ["module ModuleA where"]
       let contentB = T.unlines
-            [ "{-# OPTIONS_GHC -Wno-unused-imports #-}"
+            [ "{-# OPTIONS_GHC -Wno-unused-imports -Wmissing-signatures #-}"
             , "module ModuleB where"
             , "import ModuleA"
+            -- introduce an artificial warning for testing purposes
+            , "foo = ()"
             ]
       _ <- createDoc "ModuleA.hs" "haskell" contentA
       _ <- createDoc "ModuleB.hs" "haskell" contentB
-      expectDiagnostics []
+      expectDiagnostics [("ModuleB.hs", [(DsWarning, (3,0), "Top-level binding")])]
   , testSessionWait "package imports" $ do
       let thisDataListContent = T.unlines
             [ "module Data.List where"
@@ -538,6 +544,18 @@ diagnosticTests = testGroup "diagnostics"
       [("A.hs", [(DsError, (5, 4), "Couldn't match expected type 'Int' with actual type 'Bool'")])
       ]
     expectNoMoreDiagnostics 2
+
+  , testSessionWait "deduplicate missing module diagnostics" $  do
+      let fooContent = T.unlines [ "module Foo() where" , "import MissingModule" ]
+      doc <- createDoc "Foo.hs" "haskell" fooContent
+      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]
+
+      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing "module Foo() where" ]
+      expectDiagnostics []
+
+      changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing $ T.unlines
+            [ "module Foo() where" , "import MissingModule" ] ]
+      expectDiagnostics [("Foo.hs", [(DsError, (1,7), "Could not find module 'MissingModule'")])]
   ]
 
 codeActionTests :: TestTree

test/src/Development/IDE/Test.hs

@@ -84,12 +84,25 @@ expectNoMoreDiagnostics timeout = do
         void (LspTest.message :: Session CustomResponse)
     ignoreOthers = void anyMessage >> handleMessages
 
+-- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics,
+--   only that existing diagnostics have been cleared.
+--
+--   Rather than trying to assert the absence of diagnostics, introduce an
+--   expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic.
 expectDiagnostics :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
 expectDiagnostics
   = expectDiagnosticsWithTags
   . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing))))
 
 expectDiagnosticsWithTags :: [(FilePath, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session ()
+expectDiagnosticsWithTags [] = do
+    diagsNot <- skipManyTill anyMessage diagnostic
+    let actual = diagsNot ^. params . diagnostics
+    case actual of
+        List [] ->
+            return ()
+        _ ->
+            liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual
 expectDiagnosticsWithTags expected = do
     let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri
     expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected