Fix diagnostics update bug (#959)

* Preventively switch to uninterruptible mask in withMVar'

withMVar' is used to update the shakeSession var and it's crucial that the
third argument is not interrupted.

'mask' can still be interrupted for I/O actions and, while we were careful to
ensure none was used, if it ever breaks it will lead to very hard to debug
problems.

* refactor: move to RuleTypes

* Add a TestRequest to wait for arbitrary ide actions

Closes #955

* expectCurrentDiagnostics

* Add a test suite for cancellation

* Introduce --test-no-kick to fix cancellation tests reliability

* delete unsafeClearDiagnostics (unused)

* GetModSummaryWithoutTimestamps - remove StringBuffer

Since the contents of the buffer are not tracked by the fingerprint.

* Fix diagnostics bug

Given a FOI F with non null typechecking diagnostics D, imagine the following scenario:

1. An edit notification for F is received, creating a new version
2. GetModTime is executed, producing 0 diagnostics.
  2.1 updateFileDiagnostics is called
  2.2 setStageDiagnostics is called
  2.3 LSP.updateDiagnostics is called with a new version, resetting all the
  diagnostics for F
  2.4 newDiags=[] in updateFileDiagnostics, which is different from D (the last
  published diagnostics), which enqueues a new publishDiagnostics [] in the
  Debouncer
3. An edit notification for F is received before typechecking has a chance to
run which undoes the previous edit
4. The debouncer publishes the empty set of diagnostics after waiting 0.1s
5. GetFileContents runs and since the contents of the file haven't changed since
the last time it ran, early cutoff skips everything donwstream

Since TypeCheck is skipped, the empty set of diagnostics stays published until
another edit comes.

The goal of this change is to prevent setStageDiagnostics from losing
diagnostics from other stages. To achieve this, we recover the old diagnostics
for all stages and merge them with the new stage.

* Fix hlint

* Use Map.insert for clarity

* Fix redundant imports

* Fix "code actions after edit" experiment"

bench/lib/Experiments.hs

@@ -115,7 +115,13 @@ experiments =
         )
         ( \p doc -> do
             changeDoc doc [hygienicEdit]
-            whileM (null <$> waitForDiagnostics)
+            waitForProgressDone
+            -- NOTE ghcide used to clear and reinstall the diagnostics here
+            -- new versions no longer do, but keep this logic around
+            -- to benchmark old versions sucessfully
+            diags <- getCurrentDiagnostics doc
+            when (null diags) $
+              whileM (null <$> waitForDiagnostics)
             not . null <$> getCodeActions doc (Range p p)
         )
     ]

exe/Arguments.hs

@@ -14,6 +14,7 @@ data Arguments = Arguments
     ,argsShakeProfiling :: Maybe FilePath
     ,argsOTMemoryProfiling :: Bool
     ,argsTesting :: Bool
+    ,argsDisableKick :: Bool
     ,argsThreads :: Int
     ,argsVerbose :: Bool
     }
@@ -35,5 +36,6 @@ arguments = Arguments
       <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
       <*> switch (long "ot-memory-profiling" <> help "Record OpenTelemetry info to the eventlog. Needs the -l RTS flag to have an effect")
       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
+      <*> switch (long "test-no-kick" <> help "Disable kick. Useful for testing cancellation")
       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
       <*> switch (long "verbose" <> help "Include internal events in logging output")

exe/Main.hs

@@ -118,7 +118,15 @@ main = do
                     }
                 logLevel = if argsVerbose then minBound else Info
             debouncer <- newAsyncDebouncer
-            initialise caps (mainRule >> pluginRules plugins >> action kick)
+            let rules = do
+                  -- install the main and ghcide-plugin rules
+                  mainRule
+                  pluginRules plugins
+                  -- install the kick action, which triggers a typecheck on every
+                  -- Shake database restart, i.e. on every user edit.
+                  unless argsDisableKick $
+                    action kick
+            initialise caps rules
                 getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs
     else do
         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error

ghcide.cabal

@@ -41,6 +41,7 @@ library
         base == 4.*,
         binary,
         bytestring,
+        case-insensitive,
         containers,
         data-default,
         deepseq,

src/Development/IDE.hs

@@ -28,7 +28,6 @@ import Development.IDE.Core.Shake as X
     ShakeExtras,
     IdeRule,
     define, defineEarlyCutoff,
-    GetModificationTime(GetModificationTime),
     use, useNoFile, uses, useWithStale, useWithStaleFast, useWithStaleFast',
     FastResult(..),
     use_, useNoFile_, uses_, useWithStale_,

src/Development/IDE/Core/FileStore.hs

@@ -28,7 +28,6 @@ import           Control.Monad.Extra
 import           Development.Shake
 import           Development.Shake.Classes
 import           Control.Exception
-import           GHC.Generics
 import Data.Either.Extra
 import Data.Int (Int64)
 import Data.Time
@@ -100,15 +99,6 @@ isFileOfInterestRule = defineEarlyCutoff $ \IsFileOfInterest f -> do
     let res = maybe NotFOI IsFOI $ f `HM.lookup` filesOfInterest
     return (Just $ BS.pack $ show $ hash res, ([], Just res))
 
--- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
-type instance RuleResult GetFileContents = (FileVersion, Maybe T.Text)
-
-data GetFileContents = GetFileContents
-    deriving (Eq, Show, Generic)
-instance Hashable GetFileContents
-instance NFData   GetFileContents
-instance Binary   GetFileContents
-
 getModificationTimeRule :: VFSHandle -> Rules ()
 getModificationTimeRule vfs =
     defineEarlyCutoff $ \(GetModificationTime_ missingFileDiags) file -> do

src/Development/IDE/Core/RuleTypes.hs

@@ -2,6 +2,7 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DerivingStrategies #-}
 
@@ -37,6 +38,8 @@ import Language.Haskell.LSP.Types (NormalizedFilePath)
 import TcRnMonad (TcGblEnv)
 import qualified Data.ByteString.Char8 as BS
 import Development.IDE.Types.Options (IdeGhcSession)
+import Data.Text (Text)
+import Data.Int (Int64)
 
 data LinkableType = ObjectLinkable | BCOLinkable
   deriving (Eq,Ord,Show)
@@ -190,6 +193,55 @@ type instance RuleResult GetModIface = HiFileResult
 -- For better early cuttoff
 type instance RuleResult GetModIfaceWithoutLinkable = HiFileResult
 
+-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
+type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
+
+-- The Shake key type for getModificationTime queries
+data GetModificationTime = GetModificationTime_
+    { missingFileDiagnostics :: Bool
+      -- ^ If false, missing file diagnostics are not reported
+    }
+    deriving (Show, Generic)
+
+instance Eq GetModificationTime where
+    -- Since the diagnostics are not part of the answer, the query identity is
+    -- independent from the 'missingFileDiagnostics' field
+    _ == _ = True
+
+instance Hashable GetModificationTime where
+    -- Since the diagnostics are not part of the answer, the query identity is
+    -- independent from the 'missingFileDiagnostics' field
+    hashWithSalt salt _ = salt
+
+instance NFData   GetModificationTime
+instance Binary   GetModificationTime
+
+pattern GetModificationTime :: GetModificationTime
+pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}
+
+-- | Get the modification time of a file.
+type instance RuleResult GetModificationTime = FileVersion
+
+data FileVersion
+    = VFSVersion !Int
+    | ModificationTime
+      !Int64   -- ^ Large unit (platform dependent, do not make assumptions)
+      !Int64   -- ^ Small unit (platform dependent, do not make assumptions)
+    deriving (Show, Generic)
+
+instance NFData FileVersion
+
+vfsVersion :: FileVersion -> Maybe Int
+vfsVersion (VFSVersion i) = Just i
+vfsVersion ModificationTime{} = Nothing
+
+data GetFileContents = GetFileContents
+    deriving (Eq, Show, Generic)
+instance Hashable GetFileContents
+instance NFData   GetFileContents
+instance Binary   GetFileContents
+
+
 data FileOfInterestStatus = OnDisk | Modified
   deriving (Eq, Show, Typeable, Generic)
 instance Hashable FileOfInterestStatus

src/Development/IDE/Core/Rules.hs

@@ -734,24 +734,26 @@ getModSummaryRule = do
                 getModSummaryFromImports session fp modTime (textToStringBuffer <$> mFileContent)
         case modS of
             Right res@(ms,_) -> do
-                let fingerPrint = hash (computeFingerprint f dflags ms, hashUTC modTime)
+                let fingerPrint = hash (computeFingerprint f (fromJust $ ms_hspp_buf ms) dflags ms, hashUTC modTime)
                 return ( Just (BS.pack $ show fingerPrint) , ([], Just res))
             Left diags -> return (Nothing, (diags, Nothing))
 
     defineEarlyCutoff $ \GetModSummaryWithoutTimestamps f -> do
         ms <- use GetModSummary f
         case ms of
             Just res@(msWithTimestamps,_) -> do
-                let ms = msWithTimestamps { ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps" }
+                let ms = msWithTimestamps {
+                    ms_hs_date = error "use GetModSummary instead of GetModSummaryWithoutTimestamps",
+                    ms_hspp_buf = error "use GetModSummary instead of GetModSummaryWithoutTimestamps"
+                    }
                 dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
-                -- include the mod time in the fingerprint
-                let fp = BS.pack $ show $ hash (computeFingerprint f dflags ms)
+                let fp = BS.pack $ show $ hash (computeFingerprint f (fromJust $ ms_hspp_buf msWithTimestamps) dflags ms)
                 return (Just fp, ([], Just res))
             Nothing -> return (Nothing, ([], Nothing))
     where
         -- Compute a fingerprint from the contents of `ModSummary`,
         -- eliding the timestamps and other non relevant fields.
-        computeFingerprint f dflags ModSummary{..} =
+        computeFingerprint f sb dflags ModSummary{..} =
             let fingerPrint =
                     ( moduleNameString (moduleName ms_mod)
                     , ms_hspp_file
@@ -761,7 +763,7 @@ getModSummaryRule = do
                     , fingerPrintImports ms_textual_imps
                     )
                 fingerPrintImports = map (fmap uniq *** (moduleNameString . unLoc))
-                opts = Hdr.getOptions dflags (fromJust ms_hspp_buf) (fromNormalizedFilePath f)
+                opts = Hdr.getOptions dflags sb (fromNormalizedFilePath f)
             in fingerPrint
 
         hashUTC UTCTime{..} = (fromEnum utctDay, fromEnum utctDayTime)

src/Development/IDE/Core/Service.hs

@@ -13,7 +13,7 @@ module Development.IDE.Core.Service(
     IdeState, initialise, shutdown,
     runAction,
     writeProfile,
-    getDiagnostics, unsafeClearDiagnostics,
+    getDiagnostics,
     ideLogger,
     updatePositionMapping,
     ) where

src/Development/IDE/Core/Shake.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE ConstraintKinds            #-}
-{-# LANGUAGE PatternSynonyms            #-}
 
 -- | A Shake implementation of the compiler service.
 --
@@ -38,7 +37,7 @@ module Development.IDE.Core.Shake(
     useWithStale, usesWithStale,
     useWithStale_, usesWithStale_,
     define, defineEarlyCutoff, defineOnDisk, needOnDisk, needOnDisks,
-    getDiagnostics, unsafeClearDiagnostics,
+    getDiagnostics,
     getHiddenDiagnostics,
     IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
     getIdeGlobalExtras,
@@ -84,6 +83,7 @@ import Development.IDE.Core.Debouncer
 import Development.IDE.GHC.Compat (NameCacheUpdater(..), upNameCache )
 import Development.IDE.GHC.Orphans ()
 import Development.IDE.Core.PositionMapping
+import Development.IDE.Core.RuleTypes
 import Development.IDE.Types.Action
 import Development.IDE.Types.Logger hiding (Priority)
 import Development.IDE.Types.KnownTargets
@@ -124,7 +124,6 @@ import Data.IORef
 import NameCache
 import UniqSupply
 import PrelInfo
-import Data.Int (Int64)
 import Language.Haskell.LSP.Types.Capabilities
 import OpenTelemetry.Eventlog
 
@@ -502,7 +501,7 @@ shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do
 -- | This is a variant of withMVar where the first argument is run unmasked and if it throws
 -- an exception, the previous value is restored while the second argument is executed masked.
 withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
-withMVar' var unmasked masked = mask $ \restore -> do
+withMVar' var unmasked masked = uninterruptibleMask $ \restore -> do
     a <- takeMVar var
     b <- restore (unmasked a) `onException` putMVar var a
     (a', c) <- masked b
@@ -652,11 +651,6 @@ getHiddenDiagnostics IdeState{shakeExtras = ShakeExtras{hiddenDiagnostics}} = do
     val <- readVar hiddenDiagnostics
     return $ getAllDiagnostics val
 
--- | FIXME: This function is temporary! Only required because the files of interest doesn't work
-unsafeClearDiagnostics :: IdeState -> IO ()
-unsafeClearDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} =
-    writeVar diagnostics mempty
-
 -- | Clear the results for all files that do not match the given predicate.
 garbageCollect :: (NormalizedFilePath -> Bool) -> Action ()
 garbageCollect keep = do
@@ -998,25 +992,19 @@ updateFileDiagnostics :: MonadIO m
 updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
     modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
     let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current
+        uri = filePathToUri' fp
+        ver = vfsVersion =<< modTime
+        updateDiagnosticsWithForcing new store = do
+            store' <- evaluate $ setStageDiagnostics uri ver (T.pack $ show k) new store
+            new' <- evaluate $ getUriDiagnostics uri store'
+            return (store', new')
     mask_ $ do
         -- Mask async exceptions to ensure that updated diagnostics are always
         -- published. Otherwise, we might never publish certain diagnostics if
         -- an exception strikes between modifyVar but before
         -- publishDiagnosticsNotification.
-        newDiags <- modifyVar diagnostics $ \old -> do
-            let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
-                                  (T.pack $ show k) (map snd currentShown) old
-            let newDiags = getFileDiagnostics fp newDiagsStore
-            _ <- evaluate newDiagsStore
-            _ <- evaluate newDiags
-            pure (newDiagsStore, newDiags)
-        modifyVar_ hiddenDiagnostics $ \old -> do
-            let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime)
-                                  (T.pack $ show k) (map snd currentHidden) old
-            let newDiags = getFileDiagnostics fp newDiagsStore
-            _ <- evaluate newDiagsStore
-            _ <- evaluate newDiags
-            return newDiagsStore
+        newDiags <- modifyVar diagnostics $ updateDiagnosticsWithForcing $ map snd currentShown
+        _ <- modifyVar hiddenDiagnostics $  updateDiagnosticsWithForcing $ map snd currentHidden
         let uri = filePathToUri' fp
         let delay = if null newDiags then 0.1 else 0
         registerEvent debouncer delay uri $ do
@@ -1051,77 +1039,45 @@ actionLogger = do
     return logger
 
 
--- The Shake key type for getModificationTime queries
-data GetModificationTime = GetModificationTime_
-    { missingFileDiagnostics :: Bool
-      -- ^ If false, missing file diagnostics are not reported
-    }
-    deriving (Show, Generic)
-
-instance Eq GetModificationTime where
-    -- Since the diagnostics are not part of the answer, the query identity is
-    -- independent from the 'missingFileDiagnostics' field
-    _ == _ = True
-
-instance Hashable GetModificationTime where
-    -- Since the diagnostics are not part of the answer, the query identity is
-    -- independent from the 'missingFileDiagnostics' field
-    hashWithSalt salt _ = salt
-
-instance NFData   GetModificationTime
-instance Binary   GetModificationTime
-
-pattern GetModificationTime :: GetModificationTime
-pattern GetModificationTime = GetModificationTime_ {missingFileDiagnostics=True}
-
--- | Get the modification time of a file.
-type instance RuleResult GetModificationTime = FileVersion
-
-data FileVersion
-    = VFSVersion !Int
-    | ModificationTime
-      !Int64   -- ^ Large unit (platform dependent, do not make assumptions)
-      !Int64   -- ^ Small unit (platform dependent, do not make assumptions)
-    deriving (Show, Generic)
-
-instance NFData FileVersion
-
-vfsVersion :: FileVersion -> Maybe Int
-vfsVersion (VFSVersion i) = Just i
-vfsVersion ModificationTime{} = Nothing
-
 getDiagnosticsFromStore :: StoreItem -> [Diagnostic]
 getDiagnosticsFromStore (StoreItem _ diags) = concatMap SL.fromSortedList $ Map.elems diags
 
 
 -- | Sets the diagnostics for a file and compilation step
 --   if you want to clear the diagnostics call this with an empty list
 setStageDiagnostics
-    :: NormalizedFilePath
+    :: NormalizedUri
     -> TextDocumentVersion -- ^ the time that the file these diagnostics originate from was last edited
     -> T.Text
     -> [LSP.Diagnostic]
     -> DiagnosticStore
     -> DiagnosticStore
-setStageDiagnostics fp timeM stage diags ds  =
-    updateDiagnostics ds uri timeM diagsBySource
-    where
-        diagsBySource = Map.singleton (Just stage) (SL.toSortedList diags)
-        uri = filePathToUri' fp
+setStageDiagnostics uri ver stage diags ds = newDiagsStore where
+    -- When 'ver' is a new version, updateDiagnostics throws away diagnostics from all stages
+    -- This interacts bady with early cutoff, so we make sure to preserve diagnostics
+    -- from other stages when calling updateDiagnostics
+    -- But this means that updateDiagnostics cannot be called concurrently
+    -- for different stages anymore
+    updatedDiags = Map.insert (Just stage) (SL.toSortedList diags) oldDiags
+    oldDiags = case HMap.lookup uri ds of
+            Just (StoreItem _ byStage) -> byStage
+            _ -> Map.empty
+    newDiagsStore = updateDiagnostics ds uri ver updatedDiags
+
 
 getAllDiagnostics ::
     DiagnosticStore ->
     [FileDiagnostic]
 getAllDiagnostics =
     concatMap (\(k,v) -> map (fromUri k,ShowDiag,) $ getDiagnosticsFromStore v) . HMap.toList
 
-getFileDiagnostics ::
-    NormalizedFilePath ->
+getUriDiagnostics ::
+    NormalizedUri ->
     DiagnosticStore ->
     [LSP.Diagnostic]
-getFileDiagnostics fp ds =
+getUriDiagnostics uri ds =
     maybe [] getDiagnosticsFromStore $
-    HMap.lookup (filePathToUri' fp) ds
+    HMap.lookup uri ds
 
 filterDiagnostics ::
     (NormalizedFilePath -> Bool) ->