Soulomoon/mark dirty keys sync to hls graph1

.github/workflows/test.yml

@@ -61,6 +61,8 @@ jobs:
     needs:
       - pre_job
     runs-on: ${{ matrix.os }}
+    env:
+      LSP_TEST_LOG_STDERR: 0
     strategy:
       # We don't want to fail fast.
       # We used to fail fast, to avoid caches of failing PRs to overpopulate the CI
@@ -117,18 +119,18 @@ jobs:
       - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test
         name: Test ghcide
         # run the tests without parallelism to avoid running out of memory
-        run: cabal test ghcide-tests || cabal test ghcide-tests
+        run: cabal test ghcide-tests
 
       - if: matrix.test
         name: Test hls-plugin-api
-        run: cabal test hls-plugin-api || cabal test hls-plugin-api
+        run: cabal test hls-plugin-api
 
       - if: matrix.test
         name: Test func-test suite
         env:
           HLS_TEST_EXE: hls
           HLS_WRAPPER_TEST_EXE: hls-wrapper
-        run: cabal test func-test || cabal test func-test
+        run: cabal test func-test
 
       - if: matrix.test
         name: Test wrapper-test suite
@@ -139,120 +141,120 @@ jobs:
 
       - if: matrix.test
         name: Test hls-refactor-plugin
-        run: cabal test hls-refactor-plugin-tests || cabal test hls-refactor-plugin-tests
+        run: cabal test hls-refactor-plugin-tests
 
       - if: matrix.test
         name: Test hls-floskell-plugin
-        run: cabal test hls-floskell-plugin-tests || cabal test hls-floskell-plugin-tests
+        run: cabal test hls-floskell-plugin-tests
 
       - if: matrix.test
         name: Test hls-class-plugin
-        run: cabal test hls-class-plugin-tests || cabal test hls-class-plugin-tests
+        run: cabal test hls-class-plugin-tests
 
       - if: matrix.test
         name: Test hls-pragmas-plugin
-        run: cabal test hls-pragmas-plugin-tests || cabal test hls-pragmas-plugin-tests
+        run: cabal test hls-pragmas-plugin-tests
 
       - if: matrix.test
         name: Test hls-eval-plugin
-        run: cabal test hls-eval-plugin-tests || cabal test hls-eval-plugin-tests
+        run: cabal test hls-eval-plugin-tests
 
       - if: matrix.test
         name: Test hls-splice-plugin
-        run: cabal test hls-splice-plugin-tests || cabal test hls-splice-plugin-tests
+        run: cabal test hls-splice-plugin-tests
 
       - if: matrix.test && matrix.ghc != '9.2'
         name: Test hls-stan-plugin
-        run: cabal test hls-stan-plugin-tests || cabal test hls-stan-plugin-tests
+        run: cabal test hls-stan-plugin-tests
 
       - if: matrix.test
         name: Test hls-stylish-haskell-plugin
-        run: cabal test hls-stylish-haskell-plugin-tests || cabal test hls-stylish-haskell-plugin-tests
+        run: cabal test hls-stylish-haskell-plugin-tests
 
       - if: matrix.test
         name: Test hls-ormolu-plugin
-        run: cabal test hls-ormolu-plugin-tests || cabal test hls-ormolu-plugin-tests
+        run: cabal test hls-ormolu-plugin-tests
 
       - if: matrix.test
         name: Test hls-fourmolu-plugin
-        run: cabal test hls-fourmolu-plugin-tests || cabal test hls-fourmolu-plugin-tests
+        run: cabal test hls-fourmolu-plugin-tests
 
       - if: matrix.test
         name: Test hls-explicit-imports-plugin test suite
-        run: cabal test hls-explicit-imports-plugin-tests || cabal test hls-explicit-imports-plugin-tests
+        run: cabal test hls-explicit-imports-plugin-tests
 
       - if: matrix.test
         name: Test hls-call-hierarchy-plugin test suite
-        run: cabal test hls-call-hierarchy-plugin-tests || cabal test hls-call-hierarchy-plugin-tests
+        run: cabal test hls-call-hierarchy-plugin-tests
 
       - if: matrix.test && matrix.os != 'windows-latest'
         name: Test hls-rename-plugin test suite
-        run: cabal test hls-rename-plugin-tests || cabal test hls-rename-plugin-tests
+        run: cabal test hls-rename-plugin-tests
 
       - if: matrix.test
         name: Test hls-hlint-plugin test suite
-        run: cabal test hls-hlint-plugin-tests || cabal test hls-hlint-plugin-tests
+        run: cabal test hls-hlint-plugin-tests
 
       - if: matrix.test
         name: Test hls-module-name-plugin test suite
-        run: cabal test hls-module-name-plugin-tests || cabal test hls-module-name-plugin-tests
+        run: cabal test hls-module-name-plugin-tests
 
       - if: matrix.test
         name: Test hls-alternate-number-format-plugin test suite
-        run: cabal test hls-alternate-number-format-plugin-tests || cabal test hls-alternate-number-format-plugin-tests
+        run: cabal test hls-alternate-number-format-plugin-tests
 
       - if: matrix.test
         name: Test hls-qualify-imported-names-plugin test suite
-        run: cabal test hls-qualify-imported-names-plugin-tests || cabal test hls-qualify-imported-names-plugin-tests
+        run: cabal test hls-qualify-imported-names-plugin-tests
 
       - if: matrix.test
         name: Test hls-code-range-plugin test suite
-        run: cabal test hls-code-range-plugin-tests || cabal test hls-code-range-plugin-tests
+        run: cabal test hls-code-range-plugin-tests
 
       - if: matrix.test
         name: Test hls-change-type-signature test suite
-        run: cabal test hls-change-type-signature-plugin-tests || cabal test hls-change-type-signature-plugin-tests
+        run: cabal test hls-change-type-signature-plugin-tests
 
       - if: matrix.test
         name: Test hls-gadt-plugin test suit
-        run: cabal test hls-gadt-plugin-tests || cabal test hls-gadt-plugin-tests
+        run: cabal test hls-gadt-plugin-tests
 
       - if: matrix.test
         name: Test hls-explicit-fixity-plugin test suite
-        run: cabal test hls-explicit-fixity-plugin-tests || cabal test hls-explicit-fixity-plugin-tests
+        run: cabal test hls-explicit-fixity-plugin-tests
 
       - if: matrix.test
         name: Test hls-explicit-record-fields-plugin test suite
-        run: cabal test hls-explicit-record-fields-plugin-tests || cabal test hls-explicit-record-fields-plugin-tests
+        run: cabal test hls-explicit-record-fields-plugin-tests
 
       ## version needs to be limited since the tests depend on cabal-fmt which only builds using specific ghc versions
       - if: matrix.test && matrix.ghc == '9.2'
         name: Test hls-cabal-fmt-plugin test suite
-        run: cabal test hls-cabal-fmt-plugin-tests --flag=isolateCabalfmtTests || cabal test hls-cabal-fmt-plugin-tests --flag=isolateCabalfmtTests
+        run: cabal test hls-cabal-fmt-plugin-tests --flag=isolateCabalfmtTests
 
       - if: matrix.test
         name: Test hls-cabal-gild-plugin test suite
-        run: cabal test hls-cabal-gild-plugin-tests --flag=isolateCabalGildTests || cabal test hls-cabal-gild-plugin-tests --flag=isolateCabalGildTests
+        run: cabal test hls-cabal-gild-plugin-tests --flag=isolateCabalGildTests
 
       - if: matrix.test
         name: Test hls-cabal-plugin test suite
-        run: cabal test hls-cabal-plugin-tests || cabal test hls-cabal-plugin-tests
+        run: cabal test hls-cabal-plugin-tests
 
       - if: matrix.test
         name: Test hls-retrie-plugin test suite
-        run: cabal test hls-retrie-plugin-tests || cabal test hls-retrie-plugin-tests
+        run: cabal test hls-retrie-plugin-tests
 
       - if: matrix.test
         name: Test hls-overloaded-record-dot-plugin test suite
-        run: cabal test hls-overloaded-record-dot-plugin-tests || cabal test hls-overloaded-record-dot-plugin-tests
+        run: cabal test hls-overloaded-record-dot-plugin-tests
 
       - if: matrix.test
         name: Test hls-semantic-tokens-plugin test suite
-        run: cabal test hls-semantic-tokens-plugin-tests || cabal test hls-semantic-tokens-plugin-tests
+        run: cabal test hls-semantic-tokens-plugin-tests
 
       - if: matrix.test
         name: Test hls-notes-plugin test suite
-        run: cabal test hls-notes-plugin-tests || cabal test hls-notes-plugin-tests
+        run: cabal test hls-notes-plugin-tests
 
   test_post_job:
     if: always()

ghcide/session-loader/Development/IDE/Session.hs

@@ -106,7 +106,7 @@
 import           Database.SQLite.Simple
 import           Development.IDE.Core.Tracing         (withTrace)
 import           Development.IDE.Session.Diagnostics  (renderCradleError)
-import           Development.IDE.Types.Shake          (WithHieDb)
+import           Development.IDE.Types.Shake          (WithHieDb, toKey)
 import           HieDb.Create
 import           HieDb.Types
 import           HieDb.Utils
@@ -474,10 +474,9 @@
     clientConfig <- getClientConfigAction
     extras@ShakeExtras{restartShakeSession, ideNc, knownTargetsVar, lspEnv
                       } <- getShakeExtras
-    let invalidateShakeCache :: IO ()
-        invalidateShakeCache = do
+    let invalidateShakeCache = do
             void $ modifyVar' version succ
-            join $ atomically $ recordDirtyKeys extras GhcSessionIO [emptyFilePath]
+            return $ toKey GhcSessionIO emptyFilePath
 
     IdeOptions{ optTesting = IdeTesting optTesting
               , optCheckProject = getCheckProject
@@ -516,10 +515,10 @@
                             HM.unionWith (<>) k $ HM.fromList knownTargets
                 hasUpdate = if known /= known' then Just (unhashed known') else Nothing
             writeTVar knownTargetsVar known'
-            logDirtyKeys <- recordDirtyKeys extras GetKnownTargets [emptyFilePath]
-            return (logDirtyKeys >> pure hasUpdate)
+            return (pure hasUpdate)
           for_ hasUpdate $ \x ->
             logWith recorder Debug $ LogKnownFilesUpdated x
+          return $ toKey GetKnownTargets emptyFilePath
 
     -- Create a new HscEnv from a hieYaml root and a set of options
     let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath)
@@ -612,18 +611,14 @@
                                        , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
                                        ]
 
-          void $ modifyVar' fileToFlags $
-              Map.insert hieYaml this_flags_map
-          void $ modifyVar' filesMap $
-              flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
-
-          void $ extendKnownTargets all_targets
-
-          -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
-          invalidateShakeCache
-
+          void $ modifyVar' fileToFlags $ Map.insert hieYaml this_flags_map
+          void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets))
+          key1 <- extendKnownTargets all_targets
+          key2 <- invalidateShakeCache
           -- The VFS doesn't change on cradle edits, re-use the old one.
-          restartShakeSession VFSUnmodified "new component" []
+          restartShakeSession VFSUnmodified "new component" [] $ do
+            return [key1, key2]
+            -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
 
           -- Typecheck all files in the project on startup
           checkProject <- getCheckProject
@@ -678,7 +673,7 @@
                  InstallationMismatch{..} ->
                      return (([renderPackageSetupException cfp GhcVersionMismatch{..}], Nothing),[])
                  InstallationChecked _compileTime _ghcLibCheck -> do
                    atomicModifyIORef' cradle_files (\xs -> (cfp:xs,()))
                    session (hieYaml, toNormalizedFilePath' cfp, opts, libDir)
              -- Failure case, either a cradle error or the none cradle
              Left err -> do

ghcide/src/Development/IDE/Core/Compile.hs

@@ -72,7 +72,7 @@
 import           Data.Tuple.Extra                  (dupe)
 import           Data.Unique                       as Unique
 import           Debug.Trace
 import           Development.IDE.Core.FileStore    (resetInterfaceStore)
 import           Development.IDE.Core.Preprocessor
 import           Development.IDE.Core.RuleTypes
 import           Development.IDE.Core.Shake
@@ -91,7 +91,7 @@
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import           GHC                               (ForeignHValue,
                                                     GetDocsFailure (..),
                                                     parsedSource)
 import qualified GHC.LanguageExtensions            as LangExt
@@ -833,6 +833,7 @@
   let dir = takeDirectory targetPath
   createDirectoryIfMissing True dir
   (tempFilePath, cleanUp) <- newTempFileWithin dir
+  -- todo value delete key value here but not mark as dirty.
   (write tempFilePath >>= \x -> renameFile tempFilePath targetPath >> atomically (resetInterfaceStore se (toNormalizedFilePath' targetPath)) >> pure x)
     `onException` cleanUp
 

ghcide/src/Development/IDE/Core/FileExists.hs

@@ -28,6 +28,7 @@ import qualified Development.IDE.Core.Shake            as Shake
 import           Development.IDE.Graph
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
+import           Development.IDE.Types.Shake           (toKey)
 import qualified Focus
 import           Ide.Logger                            (Pretty (pretty),
                                                         Recorder, WithPriority,
@@ -106,11 +107,11 @@ getFileExistsMapUntracked = do
   return v
 
 -- | Modify the global store of file exists.
-modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO ()
+modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key]
 modifyFileExists state changes = do
   FileExistsMapVar var <- getIdeGlobalState state
   -- Masked to ensure that the previous values are flushed together with the map update
-  join $ mask_ $ atomicallyNamed "modifyFileExists" $ do
+  mask_ $ atomicallyNamed "modifyFileExists" $ do
     forM_ changes $ \(f,c) ->
         case fromChange c of
             Just c' -> STM.focus (Focus.insert c') f var
@@ -119,10 +120,10 @@ modifyFileExists state changes = do
     -- flush previous values
     let (fileModifChanges, fileExistChanges) =
             partition ((== FileChangeType_Changed) . snd) changes
-    mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
-    io1 <- recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges
-    io2 <- recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges
-    return (io1 <> io2)
+    keys0 <- concat <$> mapM (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges
+    let keys1 = map (toKey GetFileExists . fst) fileExistChanges
+    let keys2 = map (toKey GetModificationTime . fst) fileModifChanges
+    return (keys0 <> keys1 <> keys2)
 
 fromChange :: FileChangeType -> Maybe Bool
 fromChange FileChangeType_Created = Just True

ghcide/src/Development/IDE/Core/FileStore.hs

@@ -49,6 +49,7 @@ import           Development.IDE.Import.DependencyInformation
 import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
+import           Development.IDE.Types.Shake                  (toKey)
 import           HieDb.Create                                 (deleteMissingRealFiles)
 import           Ide.Logger                                   (Pretty (pretty),
                                                                Priority (Info),
@@ -148,24 +149,24 @@ isInterface :: NormalizedFilePath -> Bool
 isInterface f = takeExtension (fromNormalizedFilePath f) `elem` [".hi", ".hi-boot", ".hie", ".hie-boot", ".core"]
 
 -- | Reset the GetModificationTime state of interface files
-resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM ()
+resetInterfaceStore :: ShakeExtras -> NormalizedFilePath -> STM [Key]
 resetInterfaceStore state f = do
     deleteValue state GetModificationTime f
 
 -- | Reset the GetModificationTime state of watched files
 --   Assumes the list does not include any FOIs
-resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO ()
+resetFileStore :: IdeState -> [(NormalizedFilePath, LSP.FileChangeType)] -> IO [Key]
 resetFileStore ideState changes = mask $ \_ -> do
     -- we record FOIs document versions in all the stored values
     -- so NEVER reset FOIs to avoid losing their versions
     -- FOI filtering is done by the caller (LSP Notification handler)
-    forM_ changes $ \(nfp, c) -> do
-        case c of
-            LSP.FileChangeType_Changed
-            --  already checked elsewhere |  not $ HM.member nfp fois
-              -> atomically $
-               deleteValue (shakeExtras ideState) GetModificationTime nfp
-            _ -> pure ()
+    fmap concat <$>
+        forM changes $ \(nfp, c) -> do
+            case c of
+                LSP.FileChangeType_Changed
+                    --  already checked elsewhere |  not $ HM.member nfp fois
+                    -> atomically $ deleteValue (shakeExtras ideState) GetModificationTime nfp
+                _ -> pure []
 
 
 modificationTime :: FileVersion -> Maybe UTCTime
@@ -215,16 +216,18 @@ setFileModified :: Recorder (WithPriority Log)
                 -> IdeState
                 -> Bool -- ^ Was the file saved?
                 -> NormalizedFilePath
+                -> IO [Key]
                 -> IO ()
-setFileModified recorder vfs state saved nfp = do
+setFileModified recorder vfs state saved nfp actionBefore = do
     ideOptions <- getIdeOptionsIO $ shakeExtras state
     doCheckParents <- optCheckParents ideOptions
     let checkParents = case doCheckParents of
           AlwaysCheck -> True
           CheckOnSave -> saved
           _           -> False
-    join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]
-    restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") []
+    restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do
+        keys<-actionBefore
+        return (toKey GetModificationTime nfp:keys)
     when checkParents $
       typecheckParents recorder state nfp
 
@@ -244,14 +247,11 @@ typecheckParentsAction recorder nfp = do
 -- | Note that some keys have been modified and restart the session
 --   Only valid if the virtual file system was initialised by LSP, as that
 --   independently tracks which files are modified.
-setSomethingModified :: VFSModified -> IdeState -> [Key] -> String -> IO ()
-setSomethingModified vfs state keys reason = do
+setSomethingModified :: VFSModified -> IdeState -> String -> IO [Key] -> IO ()
+setSomethingModified vfs state reason actionBetweenSession = do
     -- Update database to remove any files that might have been renamed/deleted
-    atomically $ do
-        writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
-        modifyTVar' (dirtyKeys $ shakeExtras state) $ \x ->
-            foldl' (flip insertKeySet) x keys
-    void $ restartShakeSession (shakeExtras state) vfs reason []
+    atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
+    void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool
 registerFileWatches globs = do