Fix diagnostics update bug

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) ->