Reimplement shake (continued)

ghcide/bench/config.yaml

@@ -19,14 +19,35 @@ examples:
         - Distribution/Simple.hs
         - Distribution/Types/Module.hs
     extra-args: [] # extra ghcide command line args
+  - name: cabal-1module
+    package: Cabal
+    version: 3.0.0.0
+    modules:
+        - Distribution/Simple.hs
+  - name: cabal-conservative
+    package: Cabal
+    version: 3.0.0.0
+    modules:
+        - Distribution/Simple.hs
+        - Distribution/Types/Module.hs
+    extra-args:  # extra ghcide command line args
+      - --conservative-change-tracking
   # Small-sized project with TH
   - name: lsp-types
     package: lsp-types
     version: 1.0.0.1
     modules:
         - src/Language/LSP/VFS.hs
         - src/Language/LSP/Types/Lens.hs
-    extra-args: [] # extra ghcide command line args
+  - name: lsp-types-conservative
+    package: lsp-types
+    version: 1.0.0.1
+    modules:
+        - src/Language/LSP/VFS.hs
+        - src/Language/LSP/Types/Lens.hs
+    extra-args:
+      - --conservative-change-tracking
+  # Small-sized project with TH
   # Small but heavily multi-component example
   # Disabled as it is far to slow. hie-bios >0.7.2 should help
   # - name: HLS

ghcide/bench/lib/Experiments.hs

@@ -152,21 +152,22 @@ experiments =
       benchWithSetup
         "code actions after cradle edit"
         ( \docs -> do
-            unless (any (isJust . identifierP) docs) $
-                error "None of the example modules is suitable for this experiment"
-            forM_ docs $ \DocumentPositions{..} ->
-                forM_ identifierP $ \p -> changeDoc doc [charEdit p]
+            forM_ docs $ \DocumentPositions{..} -> do
+                forM identifierP $ \p -> do
+                    changeDoc doc [charEdit p]
+                    waitForProgressStart
+            void waitForBuildQueue
         )
         ( \docs -> do
             hieYamlUri <- getDocUri "hie.yaml"
             liftIO $ appendFile (fromJust $ uriToFilePath hieYamlUri) "##\n"
             sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
                 List [ FileEvent hieYamlUri FcChanged ]
-            forM_ docs $ \DocumentPositions{..} -> do
-              changeDoc doc [charEdit stringLiteralP]
-              waitForProgressStart
+            waitForProgressStart
+            waitForProgressStart
+            waitForProgressStart -- the Session logic restarts a second time
             waitForProgressDone
-            not . null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
+            not . all null . catMaybes <$> forM docs (\DocumentPositions{..} -> do
               forM identifierP $ \p ->
                 getCodeActions doc (Range p p))
         ),
@@ -421,6 +422,17 @@ waitForProgressDone = loop
       done <- null <$> getIncompleteProgressSessions
       unless done loop
 
+-- | Wait for the build queue to be empty
+waitForBuildQueue :: Session Seconds
+waitForBuildQueue = do
+    let m = SCustomMethod "test"
+    waitId <- sendRequest m (toJSON WaitForShakeQueue)
+    (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId
+    case resp of
+        ResponseMessage{_result=Right Null} -> return td
+        -- assume a ghcide binary lacking the WaitForShakeQueue method
+        _                                   -> return 0
+
 runBench ::
   (?config :: Config) =>
   (Session BenchRun -> IO BenchRun) ->
@@ -451,15 +463,8 @@ runBench runSess b = handleAny (\e -> print e >> return badRun)
             else do
                 output (showDuration t)
                 -- Wait for the delayed actions to finish
-                let m = SCustomMethod "test"
-                waitId <- sendRequest m (toJSON WaitForShakeQueue)
-                (td, resp) <- duration $ skipManyTill anyMessage $ responseForId m waitId
-                case resp of
-                    ResponseMessage{_result=Right Null} -> do
-                      loop (userWaits+t) (delayedWork+td) (n -1)
-                    _ ->
-                    -- Assume a ghcide build lacking the WaitForShakeQueue command
-                      loop (userWaits+t) delayedWork (n -1)
+                td <- waitForBuildQueue
+                loop (userWaits+t) (delayedWork+td) (n -1)
 
       (runExperiment, result) <- duration $ loop 0 0 samples
       let success = isJust result

ghcide/exe/Arguments.hs

@@ -9,15 +9,16 @@ import           Ide.Types            (IdePlugins)
 import           Options.Applicative
 
 data Arguments = Arguments
-    {argsCwd               :: Maybe FilePath
-    ,argsVersion           :: Bool
-    ,argsShakeProfiling    :: Maybe FilePath
-    ,argsOTMemoryProfiling :: Bool
-    ,argsTesting           :: Bool
-    ,argsDisableKick       :: Bool
-    ,argsThreads           :: Int
-    ,argsVerbose           :: Bool
-    ,argsCommand           :: Command
+    {argsCwd                        :: Maybe FilePath
+    ,argsVersion                    :: Bool
+    ,argsShakeProfiling             :: Maybe FilePath
+    ,argsOTMemoryProfiling          :: Bool
+    ,argsTesting                    :: Bool
+    ,argsDisableKick                :: Bool
+    ,argsThreads                    :: Int
+    ,argsVerbose                    :: Bool
+    ,argsCommand                    :: Command
+    ,argsConservativeChangeTracking :: Bool
     }
 
 getArguments :: IdePlugins IdeState -> IO Arguments
@@ -38,6 +39,7 @@ arguments plugins = Arguments
       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
       <*> switch (short 'd' <> long "verbose" <> help "Include internal events in logging output")
       <*> (commandP plugins <|> lspCommand <|> checkCommand)
+      <*> switch (long "conservative-change-tracking" <> help "disable reactive change tracking (for testing/debugging)")
       where
           checkCommand = Check <$> many (argument str (metavar "FILES/DIRS..."))
           lspCommand = LSP <$ flag' True (long "lsp" <> help "Start talking to an LSP client")

ghcide/exe/Main.hs

@@ -71,6 +71,8 @@ main = do
             then Test.plugin
             else mempty
 
+        ,Main.argsThreads = case argsThreads of 0 -> Nothing ; i -> Just (fromIntegral i)
+
         ,Main.argsIdeOptions = \config  sessionLoader ->
             let defOptions = defaultIdeOptions sessionLoader
             in defOptions
@@ -80,5 +82,6 @@ main = do
                 , optShakeOptions = (optShakeOptions defOptions){shakeThreads = argsThreads}
                 , optCheckParents = pure $ checkParents config
                 , optCheckProject = pure $ checkProject config
+                , optRunSubset = not argsConservativeChangeTracking
                 }
         }

ghcide/ghcide.cabal

@@ -48,6 +48,7 @@ library
         dependent-map,
         dependent-sum,
         dlist,
+        exceptions,
         -- we can't use >= 1.7.10 while we have to use hlint == 3.2.*
         extra >= 1.7.4 && < 1.7.10,
         fuzzy,
@@ -76,7 +77,7 @@ library
         rope-utf16-splay,
         safe,
         safe-exceptions,
-        hls-graph ^>= 1.4,
+        hls-graph ^>= 1.5,
         sorted-list,
         sqlite-simple,
         stm,
@@ -269,6 +270,7 @@ benchmark benchHist
         directory,
         extra,
         filepath,
+        lens,
         optparse-applicative,
         shake,
         text,

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

@@ -250,7 +250,6 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
 
     IdeOptions{ optTesting = IdeTesting optTesting
               , optCheckProject = getCheckProject
-              , optModifyDynFlags
               , optExtensions
               } <- getIdeOptions
 
@@ -264,6 +263,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
               TargetModule _ -> do
                 found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations
                 return (targetTarget, found)
+          recordDirtyKeys extras GetKnownTargets  [emptyFilePath]
           modifyVarIO' knownTargetsVar $ traverseHashed $ \known -> do
             let known' = HM.unionWith (<>) known $ HM.fromList $ map (second Set.fromList) knownTargets
             when (known /= known') $
@@ -390,7 +390,7 @@ loadSessionWithOptions SessionLoadingOptions{..} dir = do
 
           -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
           invalidateShakeCache
-          restartShakeSession []
+          restartShakeSession "new component" []
 
           -- Typecheck all files in the project on startup
           checkProject <- getCheckProject

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

@@ -48,7 +48,6 @@ 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                  (SomeShakeValue)
 import           HieDb.Create                                 (deleteMissingRealFiles)
 import           Ide.Plugin.Config                            (CheckParents (..),
                                                                Config)
@@ -271,7 +270,7 @@ setFileModified state saved nfp = do
     when (isJust setVirtualFileContents) $
         fail "setFileModified can't be called on this type of VFSHandle"
     recordDirtyKeys (shakeExtras state) GetModificationTime [nfp]
-    restartShakeSession (shakeExtras state) []
+    restartShakeSession (shakeExtras state) (fromNormalizedFilePath nfp ++ " (modified)") []
     when checkParents $
       typecheckParents state nfp
 
@@ -294,16 +293,16 @@ typecheckParentsAction 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 :: IdeState -> [SomeShakeValue] -> IO ()
-setSomethingModified state keys = do
+setSomethingModified :: IdeState -> [Key] -> String -> IO ()
+setSomethingModified state keys reason = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setSomethingModified can't be called on this type of VFSHandle"
     -- Update database to remove any files that might have been renamed/deleted
     atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) deleteMissingRealFiles
     atomicModifyIORef_ (dirtyKeys $ shakeExtras state) $ \x ->
         foldl' (flip HSet.insert) x keys
-    void $ restartShakeSession (shakeExtras state) []
+    void $ restartShakeSession (shakeExtras state) reason []
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool
 registerFileWatches globs = do