From 684a85042f6ca209d6c8f3b18e41b6d1d774da66 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 23 Apr 2024 04:59:55 +0800 Subject: [PATCH 01/51] passing keys need to be update directly to restartShakeSession --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- ghcide/src/Development/IDE/Core/FileStore.hs | 4 ++-- ghcide/src/Development/IDE/Core/Shake.hs | 6 ++++-- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 2 +- 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index a0d870d590..4b4294cd8a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -623,7 +623,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do invalidateShakeCache -- The VFS doesn't change on cradle edits, re-use the old one. - restartShakeSession VFSUnmodified "new component" [] + restartShakeSession VFSUnmodified "new component" [] [] -- Typecheck all files in the project on startup checkProject <- getCheckProject diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 7be4c71827..49e9ad3b5c 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -224,7 +224,7 @@ setFileModified recorder vfs state saved nfp = do CheckOnSave -> saved _ -> False join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] - restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] + restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] [] when checkParents $ typecheckParents recorder state nfp @@ -251,7 +251,7 @@ setSomethingModified vfs state keys reason = 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 [] + void $ restartShakeSession (shakeExtras state) vfs reason [] keys registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index a215ee42ef..d5ed2bc579 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -300,6 +300,7 @@ data ShakeExtras = ShakeExtras :: VFSModified -> String -> [DelayedAction ()] + -> [Key] -> IO () #if MIN_VERSION_ghc(9,3,0) ,ideNc :: NameCache @@ -759,13 +760,14 @@ delayedAction a = do -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO () -shakeRestart recorder IdeState{..} vfs reason acts = +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> [Key] -> IO () +shakeRestart recorder IdeState{..} vfs reason acts keys = withMVar' shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner res <- shakeDatabaseProfile shakeDb + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 7126dc14b1..2e305b2e45 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -133,7 +133,7 @@ Then we restart the shake session, so that changes to our virtual files are actu restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg = do join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] [] -- ---------------------------------------------------------------- -- Plugin Rules From 5d098374c0129b545721cd433d74bbe8988c8be5 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 00:42:02 +0800 Subject: [PATCH 02/51] send actions to run between restart --- .../session-loader/Development/IDE/Session.hs | 20 ++++++-------- ghcide/src/Development/IDE/Core/FileStore.hs | 23 +++++++++------- ghcide/src/Development/IDE/Core/Shake.hs | 8 +++--- .../src/Development/IDE/LSP/Notifications.hs | 26 +++++++++---------- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 20 +++++++------- 5 files changed, 48 insertions(+), 49 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 4b4294cd8a..e862261480 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -611,19 +611,15 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do [ "No cradle target found. Is this file listed in the targets of your cradle?" , "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 - -- The VFS doesn't change on cradle edits, re-use the old one. - restartShakeSession VFSUnmodified "new component" [] [] + restartShakeSession VFSUnmodified "new component" [] $ do + 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 -- Typecheck all files in the project on startup checkProject <- getCheckProject diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 49e9ad3b5c..d0e5d69876 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -216,15 +216,17 @@ setFileModified :: Recorder (WithPriority Log) -> Bool -- ^ Was the file saved? -> NormalizedFilePath -> IO () -setFileModified recorder vfs state saved nfp = do + -> IO () +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 + actionBefore + join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] when checkParents $ typecheckParents recorder state nfp @@ -244,14 +246,15 @@ 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 -> [Key] -> String -> IO () -> IO () +setSomethingModified vfs state keys 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 [] keys + void $ restartShakeSession (shakeExtras state) vfs reason [] $ do + actionBetweenSession + atomically $ do + writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> + foldl' (flip insertKeySet) x keys registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index d5ed2bc579..9003917f0c 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -300,7 +300,7 @@ data ShakeExtras = ShakeExtras :: VFSModified -> String -> [DelayedAction ()] - -> [Key] + -> IO () -> IO () #if MIN_VERSION_ghc(9,3,0) ,ideNc :: NameCache @@ -760,14 +760,14 @@ delayedAction a = do -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> [Key] -> IO () -shakeRestart recorder IdeState{..} vfs reason acts keys = +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO () -> IO () +shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = withMVar' shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner res <- shakeDatabaseProfile shakeDb - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + ioActionBetweenShakeSession backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 1772612e2d..f468c55e55 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -72,32 +72,32 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat whenUriFile _uri $ \file -> do -- We don't know if the file actually exists, or if the contents match those on disk -- For example, vscode restores previously unsaved contents on open - addFileOfInterest ide file Modified{firstOpen=True} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file - logWith recorder Debug $ LogOpenedTextDocument _uri + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file Modified{firstOpen=True} + logWith recorder Debug $ LogOpenedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> liftIO $ do atomically $ updatePositionMapping ide identifier changes whenUriFile _uri $ \file -> do - addFileOfInterest ide file Modified{firstOpen=False} - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide False file $ + addFileOfInterest ide file Modified{firstOpen=False} logWith recorder Debug $ LogModifiedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do - addFileOfInterest ide file OnDisk - setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file + setFileModified (cmapWithPrio LogFileStore recorder) (VFSModified vfs) ide True file $ + addFileOfInterest ide file OnDisk logWith recorder Debug $ LogSavedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do - deleteFileOfInterest ide file let msg = "Closed text document: " <> getUri _uri - scheduleGarbageCollection ide - setSomethingModified (VFSModified vfs) ide [] $ Text.unpack msg + setSomethingModified (VFSModified vfs) ide [] (Text.unpack msg) $ do + deleteFileOfInterest ide file + scheduleGarbageCollection ide logWith recorder Debug $ LogClosedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ @@ -116,9 +116,9 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat unless (null fileEvents') $ do let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) - modifyFileExists ide fileEvents' - resetFileStore ide fileEvents' - setSomethingModified (VFSModified vfs) ide [] msg + setSomethingModified (VFSModified vfs) ide [] msg $ do + modifyFileExists ide fileEvents' + resetFileStore ide fileEvents' , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 2e305b2e45..34f0095f64 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -90,26 +90,26 @@ descriptor recorder plId = \ide vfs _ (DidOpenTextDocumentParams TextDocumentItem{_uri, _version}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocOpened _uri - addFileOfInterest recorder ide file Modified{firstOpen = True} - restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" + restartCabalShakeSession (shakeExtras ide) vfs file "(opened)" $ + addFileOfInterest recorder ide file Modified{firstOpen = True} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidChange $ \ide vfs _ (DidChangeTextDocumentParams VersionedTextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocModified _uri - addFileOfInterest recorder ide file Modified{firstOpen = False} - restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" + restartCabalShakeSession (shakeExtras ide) vfs file "(changed)" $ + addFileOfInterest recorder ide file Modified{firstOpen = False} , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidSave $ \ide vfs _ (DidSaveTextDocumentParams TextDocumentIdentifier{_uri} _) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocSaved _uri - addFileOfInterest recorder ide file OnDisk - restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" + restartCabalShakeSession (shakeExtras ide) vfs file "(saved)" $ + addFileOfInterest recorder ide file OnDisk , mkPluginNotificationHandler LSP.SMethod_TextDocumentDidClose $ \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do log' Debug $ LogDocClosed _uri - deleteFileOfInterest recorder ide file - restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" + restartCabalShakeSession (shakeExtras ide) vfs file "(closed)" $ + deleteFileOfInterest recorder ide file ] , pluginConfigDescriptor = defaultConfigDescriptor { configHasDiagnostics = True @@ -132,8 +132,8 @@ Then we restart the shake session, so that changes to our virtual files are actu -} restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg = do - join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] [] + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ + join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] -- ---------------------------------------------------------------- -- Plugin Rules From 13528d7d4b5aba5e33fbdf970fc2eeabe9e87191 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 00:44:58 +0800 Subject: [PATCH 03/51] fix --- ghcide/src/Development/IDE/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 0c7581f75d..1d8f064709 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -364,7 +364,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re let msg = T.pack $ show cfg logWith recorder Debug $ LogConfigurationChange msg modifyClientSettings ide (const $ Just cfgObj) - setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" + setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" $ return () runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats From fdbb7aaca816cdbf23d7904148969b41350d76c8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 00:49:24 +0800 Subject: [PATCH 04/51] fix --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 7 ++++--- plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs | 6 ++---- 3 files changed, 7 insertions(+), 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 9003917f0c..f49bfe56b8 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -766,8 +766,8 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - res <- shakeDatabaseProfile shakeDb ioActionBetweenShakeSession + res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 34f0095f64..404ba71ba2 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -130,9 +130,10 @@ needs to be re-parsed. That's what we do when we record the dirty key that our p rule depends on. Then we restart the shake session, so that changes to our virtual files are actually picked up. -} -restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () -restartCabalShakeSession shakeExtras vfs file actionMsg = do - restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ +restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () -> IO () +restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do + restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do + actionBetweenSession join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] -- ---------------------------------------------------------------- diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index bb7c51be59..4d9aec1ad2 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -211,10 +211,8 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ - (do queueForEvaluation st nfp - setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval") - (do unqueueForEvaluation st nfp - setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval") + (setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval" $ queueForEvaluation st nfp) + (setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval" $ unqueueForEvaluation st nfp) (initialiseSessionForEval (needsQuickCheck tests) st nfp) evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId From 6fc3646741af3d62b9729f173ddcc903f443a4ef Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 01:08:01 +0800 Subject: [PATCH 05/51] some more fix up --- ghcide/src/Development/IDE/Core/FileStore.hs | 6 ++---- ghcide/src/Development/IDE/Core/Shake.hs | 11 +++++++++- .../src/Development/IDE/LSP/Notifications.hs | 4 ++-- ghcide/src/Development/IDE/Main.hs | 15 +++++++------ .../src/Ide/Plugin/Eval/CodeLens.hs | 21 +++++++++++++------ 5 files changed, 38 insertions(+), 19 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index d0e5d69876..762f761dbe 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -246,15 +246,13 @@ 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 () -> IO () -setSomethingModified vfs state keys reason actionBetweenSession = do +setSomethingModified :: VFSModified -> IdeState -> String -> IO () -> IO () +setSomethingModified vfs state reason actionBetweenSession = do -- Update database to remove any files that might have been renamed/deleted void $ restartShakeSession (shakeExtras state) vfs reason [] $ do actionBetweenSession atomically $ do writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - modifyTVar' (dirtyKeys $ shakeExtras state) $ \x -> - foldl' (flip insertKeySet) x keys registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f49bfe56b8..9348dd692e 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -57,7 +57,7 @@ module Development.IDE.Core.Shake( FileVersion(..), updatePositionMapping, updatePositionMappingHelper, - deleteValue, recordDirtyKeys, + deleteValue, recordDirtyKeys, recordDirtyKeySet, WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -579,6 +579,15 @@ recordDirtyKeys ShakeExtras{dirtyKeys} key file = do return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file) +recordDirtyKeySet + :: ShakeExtras + -> [Key] + -> STM (IO ()) +recordDirtyKeySet ShakeExtras{dirtyKeys} keys = do + modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x keys + return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do + addEvent (fromString $ unlines $ "dirty " : map show keys) + -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: forall k v. diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index f468c55e55..cbfa92380d 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -95,7 +95,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat \ide vfs _ (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> liftIO $ do whenUriFile _uri $ \file -> do let msg = "Closed text document: " <> getUri _uri - setSomethingModified (VFSModified vfs) ide [] (Text.unpack msg) $ do + setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do deleteFileOfInterest ide file scheduleGarbageCollection ide logWith recorder Debug $ LogClosedTextDocument _uri @@ -116,7 +116,7 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat unless (null fileEvents') $ do let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) - setSomethingModified (VFSModified vfs) ide [] msg $ do + setSomethingModified (VFSModified vfs) ide msg $ do modifyFileExists ide fileEvents' resetFileStore ide fileEvents' diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 1d8f064709..fc2e7be561 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -18,8 +18,8 @@ import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Exception.Safe (SomeException, catchAny, displayException) -import Control.Monad.Extra (concatMapM, unless, - when) +import Control.Monad.Extra (concatMapM, join, + unless, when) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as J import Data.Coerce (coerce) @@ -56,6 +56,7 @@ import Development.IDE.Core.Service (initialise, import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), IndexQueue, + recordDirtyKeys, shakeSessionInit, uses) import qualified Development.IDE.Core.Shake as Shake @@ -89,7 +90,8 @@ import Development.IDE.Types.Options (IdeGhcSession, optModifyDynFlags, optTesting) import Development.IDE.Types.Shake (WithHieDb, toKey) -import GHC.Conc (getNumProcessors) +import GHC.Conc (atomically, + getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) import GHC.IO.Handle (hDuplicate) import HIE.Bios.Cradle (findCradle) @@ -362,9 +364,10 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Nothing -> pure () Just ide -> liftIO $ do let msg = T.pack $ show cfg - logWith recorder Debug $ LogConfigurationChange msg - modifyClientSettings ide (const $ Just cfgObj) - setSomethingModified Shake.VFSUnmodified ide [toKey Rules.GetClientSettings emptyFilePath] "config change" $ return () + setSomethingModified Shake.VFSUnmodified ide "config change" $ do + logWith recorder Debug $ LogConfigurationChange msg + modifyClientSettings ide (const $ Just cfgObj) + join $ atomically $ recordDirtyKeys (shakeExtras ide) Rules.GetClientSettings [emptyFilePath] runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index 4d9aec1ad2..be9d0472c8 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -23,8 +23,8 @@ import Control.Exception (bracket_, try) import qualified Control.Exception as E import Control.Lens (_1, _3, ix, (%~), (<&>), (^.)) -import Control.Monad (guard, void, - when) +import Control.Monad (guard, join, + void, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Except (ExceptT (..), runExceptT) @@ -47,7 +47,8 @@ import Development.IDE.Core.RuleTypes (LinkableResult (l NeedsCompilation (NeedsCompilation), TypeCheck (..), tmrTypechecked) -import Development.IDE.Core.Shake (useNoFile_, +import Development.IDE.Core.Shake (shakeExtras, + useNoFile_, useWithStale_, use_, uses_) import Development.IDE.GHC.Compat hiding (typeKind, @@ -84,15 +85,18 @@ import Development.IDE.Core.RuleTypes (GetLinkable (GetL GetModuleGraph (GetModuleGraph), GhcSessionDeps (GhcSessionDeps), ModSummaryResult (msrModSummary)) -import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) +import Development.IDE.Core.Shake (VFSModified (VFSUnmodified), + recordDirtyKeys) import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc), unLoc) import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv)) import qualified GHC.LanguageExtensions.Type as LangExt (Extension (..)) +import Control.Concurrent.STM.Stats (atomically) import Development.IDE.Core.FileStore (setSomethingModified) import Development.IDE.Core.PluginUtils +import Development.IDE.Graph (ShakeOptions (shakeExtra)) import Development.IDE.Types.Shake (toKey) import GHC.Types.SrcLoc (UnhelpfulSpanReason (UnhelpfulInteractive)) import Ide.Logger (Priority (..), @@ -211,8 +215,13 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ - (setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval" $ queueForEvaluation st nfp) - (setSomethingModified VFSUnmodified st [toKey IsEvaluating nfp] "Eval" $ unqueueForEvaluation st nfp) + (setSomethingModified VFSUnmodified st "Eval" $ do + join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp] + queueForEvaluation st nfp + ) + (setSomethingModified VFSUnmodified st "Eval" $ do + join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp] + unqueueForEvaluation st nfp) (initialiseSessionForEval (needsQuickCheck tests) st nfp) evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId From e247ae13e780a0475040a6285c1c976585528f29 Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 01:46:11 +0800 Subject: [PATCH 06/51] use IO [Key] --- .../session-loader/Development/IDE/Session.hs | 16 ++++++------- ghcide/src/Development/IDE/Core/FileExists.hs | 12 ++++++---- ghcide/src/Development/IDE/Core/FileStore.hs | 15 ++++++------ ghcide/src/Development/IDE/Core/OfInterest.hs | 13 +++++++---- ghcide/src/Development/IDE/Core/Shake.hs | 22 +++++------------- .../src/Development/IDE/LSP/Notifications.hs | 4 ++-- ghcide/src/Development/IDE/Main.hs | 3 +-- .../hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 23 +++++++++++-------- .../src/Ide/Plugin/Eval/CodeLens.hs | 10 ++++---- 9 files changed, 58 insertions(+), 60 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index e862261480..84e8a9011f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -106,7 +106,7 @@ import qualified Data.HashSet as Set 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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) @@ -617,9 +616,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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 + key1 <- extendKnownTargets all_targets + key2 <- invalidateShakeCache + return [key1, key2] -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - invalidateShakeCache -- Typecheck all files in the project on startup checkProject <- getCheckProject diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 4ca55a8d24..eb87051812 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/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 + keys <- join $ mask_ $ atomicallyNamed "modifyFileExists" $ do forM_ changes $ \(f,c) -> case fromChange c of Just c' -> STM.focus (Focus.insert c') f var @@ -120,9 +121,10 @@ modifyFileExists state changes = do 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) + let keys1 = map (toKey GetFileExists . fst) fileExistChanges + let keys2 = map (toKey GetModificationTime . fst) fileModifChanges + return $ return (keys1 <> keys2) + return keys fromChange :: FileChangeType -> Maybe Bool fromChange FileChangeType_Created = Just True diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 762f761dbe..31d110c466 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/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), @@ -215,7 +216,7 @@ setFileModified :: Recorder (WithPriority Log) -> IdeState -> Bool -- ^ Was the file saved? -> NormalizedFilePath - -> IO () + -> IO [Key] -> IO () setFileModified recorder vfs state saved nfp actionBefore = do ideOptions <- getIdeOptionsIO $ shakeExtras state @@ -225,8 +226,8 @@ setFileModified recorder vfs state saved nfp actionBefore = do CheckOnSave -> saved _ -> False restartShakeSession (shakeExtras state) vfs (fromNormalizedFilePath nfp ++ " (modified)") [] $ do - actionBefore - join $ atomically $ recordDirtyKeys (shakeExtras state) GetModificationTime [nfp] + keys<-actionBefore + return (toKey GetModificationTime nfp:keys) when checkParents $ typecheckParents recorder state nfp @@ -246,13 +247,13 @@ 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 -> String -> IO () -> IO () +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 void $ restartShakeSession (shakeExtras state) vfs reason [] $ do - actionBetweenSession - atomically $ do - writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + keys <- actionBetweenSession + atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) + return keys registerFileWatches :: [String] -> LSP.LspT Config IO Bool registerFileWatches globs = do diff --git a/ghcide/src/Development/IDE/Core/OfInterest.hs b/ghcide/src/Development/IDE/Core/OfInterest.hs index 0be869b45a..098b2dedaa 100644 --- a/ghcide/src/Development/IDE/Core/OfInterest.hs +++ b/ghcide/src/Development/IDE/Core/OfInterest.hs @@ -40,6 +40,7 @@ import Development.IDE.Plugin.Completions.Types import Development.IDE.Types.Exports import Development.IDE.Types.Location import Development.IDE.Types.Options (IdeTesting (..)) +import Development.IDE.Types.Shake (toKey) import GHC.TypeLits (KnownSymbol) import Ide.Logger (Pretty (pretty), Priority (..), @@ -103,24 +104,26 @@ getFilesOfInterestUntracked = do OfInterestVar var <- getIdeGlobalAction liftIO $ readVar var -addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO () +addFileOfInterest :: IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] addFileOfInterest state f v = do OfInterestVar var <- getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do let (prev, new) = HashMap.alterF (, Just v) f dict pure (new, (prev, new)) - when (prev /= Just v) $ do - join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] + if prev /= Just v + then do logWith (ideLogger state) Debug $ LogSetFilesOfInterest (HashMap.toList files) + return [toKey IsFileOfInterest f] + else return [] -deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO () +deleteFileOfInterest :: IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest state f = do OfInterestVar var <- getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f - join $ atomically $ recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] logWith (ideLogger state) Debug $ LogSetFilesOfInterest (HashMap.toList files) + return [toKey IsFileOfInterest f] scheduleGarbageCollection :: IdeState -> IO () scheduleGarbageCollection state = do GarbageCollectVar var <- getIdeGlobalState state diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 9348dd692e..f6c23a8405 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -57,7 +57,7 @@ module Development.IDE.Core.Shake( FileVersion(..), updatePositionMapping, updatePositionMappingHelper, - deleteValue, recordDirtyKeys, recordDirtyKeySet, + deleteValue, recordDirtyKeys, WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -300,7 +300,7 @@ data ShakeExtras = ShakeExtras :: VFSModified -> String -> [DelayedAction ()] - -> IO () + -> IO [Key] -> IO () #if MIN_VERSION_ghc(9,3,0) ,ideNc :: NameCache @@ -569,21 +569,10 @@ deleteValue ShakeExtras{dirtyKeys, state} key file = do modifyTVar' dirtyKeys $ insertKeySet (toKey key file) recordDirtyKeys - :: Shake.ShakeValue k - => ShakeExtras - -> k - -> [NormalizedFilePath] - -> STM (IO ()) -recordDirtyKeys ShakeExtras{dirtyKeys} key file = do - modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x (toKey key <$> file) - return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do - addEvent (fromString $ unlines $ "dirty " <> show key : map fromNormalizedFilePath file) - -recordDirtyKeySet :: ShakeExtras -> [Key] -> STM (IO ()) -recordDirtyKeySet ShakeExtras{dirtyKeys} keys = do +recordDirtyKeys ShakeExtras{dirtyKeys} keys = do modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x keys return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do addEvent (fromString $ unlines $ "dirty " : map show keys) @@ -769,13 +758,14 @@ delayedAction a = do -- | Restart the current 'ShakeSession' with the given system actions. -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO () -> IO () +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = withMVar' shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - ioActionBetweenShakeSession + keys <- ioActionBetweenShakeSession + join $ atomically $ recordDirtyKeys shakeExtras keys res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index cbfa92380d..7b5fe7adeb 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -96,8 +96,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat whenUriFile _uri $ \file -> do let msg = "Closed text document: " <> getUri _uri setSomethingModified (VFSModified vfs) ide (Text.unpack msg) $ do - deleteFileOfInterest ide file scheduleGarbageCollection ide + deleteFileOfInterest ide file logWith recorder Debug $ LogClosedTextDocument _uri , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWatchedFiles $ @@ -117,8 +117,8 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) setSomethingModified (VFSModified vfs) ide msg $ do - modifyFileExists ide fileEvents' resetFileStore ide fileEvents' + modifyFileExists ide fileEvents' , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index fc2e7be561..b9c977e08e 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -56,7 +56,6 @@ import Development.IDE.Core.Service (initialise, import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), IndexQueue, - recordDirtyKeys, shakeSessionInit, uses) import qualified Development.IDE.Core.Shake as Shake @@ -367,7 +366,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re setSomethingModified Shake.VFSUnmodified ide "config change" $ do logWith recorder Debug $ LogConfigurationChange msg modifyClientSettings ide (const $ Just cfgObj) - join $ atomically $ recordDirtyKeys (shakeExtras ide) Rules.GetClientSettings [emptyFilePath] + return [toKey Rules.GetClientSettings emptyFilePath] runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index 404ba71ba2..b9db5f816f 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -24,9 +24,10 @@ import Data.Typeable import Development.IDE as D import Development.IDE.Core.Shake (restartShakeSession) import qualified Development.IDE.Core.Shake as Shake -import Development.IDE.Graph (alwaysRerun) +import Development.IDE.Graph (Key, alwaysRerun) import qualified Development.IDE.Plugin.Completions.Logic as Ghcide import qualified Development.IDE.Plugin.Completions.Types as Ghcide +import Development.IDE.Types.Shake (toKey) import GHC.Generics import qualified Ide.Plugin.Cabal.Completion.Completer.Types as CompleterTypes import qualified Ide.Plugin.Cabal.Completion.Completions as Completions @@ -130,11 +131,11 @@ needs to be re-parsed. That's what we do when we record the dirty key that our p rule depends on. Then we restart the shake session, so that changes to our virtual files are actually picked up. -} -restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO () -> IO () +restartCabalShakeSession :: ShakeExtras -> VFS.VFS -> NormalizedFilePath -> String -> IO [Key] -> IO () restartCabalShakeSession shakeExtras vfs file actionMsg actionBetweenSession = do restartShakeSession shakeExtras (VFSModified vfs) (fromNormalizedFilePath file ++ " " ++ actionMsg) [] $ do - actionBetweenSession - join $ atomically $ Shake.recordDirtyKeys shakeExtras GetModificationTime [file] + keys <- actionBetweenSession + return (toKey GetModificationTime file:keys) -- ---------------------------------------------------------------- -- Plugin Rules @@ -250,24 +251,26 @@ getCabalFilesOfInterestUntracked = do OfInterestCabalVar var <- Shake.getIdeGlobalAction liftIO $ readVar var -addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO () +addFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> FileOfInterestStatus -> IO [Key] addFileOfInterest recorder state f v = do OfInterestCabalVar var <- Shake.getIdeGlobalState state (prev, files) <- modifyVar var $ \dict -> do let (prev, new) = HashMap.alterF (,Just v) f dict pure (new, (prev, new)) - when (prev /= Just v) $ do - join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] - log' Debug $ LogFOI files + if prev /= Just v + then do + log' Debug $ LogFOI files + return [toKey IsCabalFileOfInterest f] + else return [] where log' = logWith recorder -deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO () +deleteFileOfInterest :: Recorder (WithPriority Log) -> IdeState -> NormalizedFilePath -> IO [Key] deleteFileOfInterest recorder state f = do OfInterestCabalVar var <- Shake.getIdeGlobalState state files <- modifyVar' var $ HashMap.delete f - join $ atomically $ Shake.recordDirtyKeys (shakeExtras state) IsFileOfInterest [f] log' Debug $ LogFOI files + return [toKey IsFileOfInterest f] where log' = logWith recorder diff --git a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs index be9d0472c8..8701526b65 100644 --- a/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs +++ b/plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs @@ -85,8 +85,7 @@ import Development.IDE.Core.RuleTypes (GetLinkable (GetL GetModuleGraph (GetModuleGraph), GhcSessionDeps (GhcSessionDeps), ModSummaryResult (msrModSummary)) -import Development.IDE.Core.Shake (VFSModified (VFSUnmodified), - recordDirtyKeys) +import Development.IDE.Core.Shake (VFSModified (VFSUnmodified)) import qualified Development.IDE.GHC.Compat.Core as Compat (InteractiveImport (IIModule)) import qualified Development.IDE.GHC.Compat.Core as SrcLoc (HasSrcSpan (getLoc), unLoc) @@ -216,12 +215,13 @@ runEvalCmd recorder plId st mtoken EvalParams{..} = -- enable codegen for the module which we need to evaluate. final_hscEnv <- liftIO $ bracket_ (setSomethingModified VFSUnmodified st "Eval" $ do - join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp] queueForEvaluation st nfp + return [toKey IsEvaluating nfp] ) (setSomethingModified VFSUnmodified st "Eval" $ do - join $ atomically $ recordDirtyKeys (shakeExtras st) IsEvaluating [nfp] - unqueueForEvaluation st nfp) + unqueueForEvaluation st nfp + return [toKey IsEvaluating nfp] + ) (initialiseSessionForEval (needsQuickCheck tests) st nfp) evalCfg <- liftIO $ runAction "eval: config" st $ getEvalConfig plId From 7b7ea4d726a09d45cbeff28a92e807dd8b383d1b Mon Sep 17 00:00:00 2001 From: Patrick Date: Thu, 25 Apr 2024 02:56:23 +0800 Subject: [PATCH 07/51] remove double return --- ghcide/src/Development/IDE/Core/FileExists.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index eb87051812..deeee49c33 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -111,7 +111,7 @@ modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Ke modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update - keys <- join $ mask_ $ atomicallyNamed "modifyFileExists" $ do + keys <- mask_ $ atomicallyNamed "modifyFileExists" $ do forM_ changes $ \(f,c) -> case fromChange c of Just c' -> STM.focus (Focus.insert c') f var @@ -123,7 +123,7 @@ modifyFileExists state changes = do mapM_ (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges let keys1 = map (toKey GetFileExists . fst) fileExistChanges let keys2 = map (toKey GetModificationTime . fst) fileModifChanges - return $ return (keys1 <> keys2) + return (keys1 <> keys2) return keys fromChange :: FileChangeType -> Maybe Bool From c31a3756ed3e428d6b5b6246922318453e6147b6 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Fri, 26 Apr 2024 20:54:46 +0800 Subject: [PATCH 08/51] Update ghcide/src/Development/IDE/Core/FileExists.hs Co-authored-by: wz1000 --- ghcide/src/Development/IDE/Core/FileExists.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index deeee49c33..af1fd45559 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -111,7 +111,7 @@ modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Ke modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state -- Masked to ensure that the previous values are flushed together with the map update - keys <- 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 From bfb06a3565d4d6188b357061cc7f9c18aa1d7dd7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 26 Apr 2024 20:59:01 +0800 Subject: [PATCH 09/51] minor fix --- ghcide/session-loader/Development/IDE/Session.hs | 7 +++---- ghcide/src/Development/IDE/Core/FileExists.hs | 1 - ghcide/src/Development/IDE/Core/FileStore.hs | 6 ++---- 3 files changed, 5 insertions(+), 9 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 84e8a9011f..d93f654e21 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -610,12 +610,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do [ "No cradle target found. Is this file listed in the targets of your cradle?" , "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)) -- The VFS doesn't change on cradle edits, re-use the old one. restartShakeSession VFSUnmodified "new component" [] $ do - 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 return [key1, key2] diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index af1fd45559..f1840b9ffd 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -124,7 +124,6 @@ modifyFileExists state changes = do let keys1 = map (toKey GetFileExists . fst) fileExistChanges let keys2 = map (toKey GetModificationTime . fst) fileModifChanges return (keys1 <> keys2) - return keys fromChange :: FileChangeType -> Maybe Bool fromChange FileChangeType_Created = Just True diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 31d110c466..145e9dc905 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -250,10 +250,8 @@ typecheckParentsAction recorder nfp = 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 - void $ restartShakeSession (shakeExtras state) vfs reason [] $ do - keys <- actionBetweenSession - atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles) - return keys + 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 From bbc5c9507ae6aa7b66a78342de0265efbf7f6f46 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 03:52:43 +0800 Subject: [PATCH 10/51] capture more dirty keys to between sessions --- ghcide/src/Development/IDE/Core/FileExists.hs | 4 ++-- ghcide/src/Development/IDE/Core/FileStore.hs | 18 +++++++++--------- ghcide/src/Development/IDE/Core/Shake.hs | 5 +++-- .../src/Development/IDE/LSP/Notifications.hs | 5 +++-- 4 files changed, 17 insertions(+), 15 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index f1840b9ffd..28c633f93d 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -120,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 + keys0 <- concat <$> mapM (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges let keys1 = map (toKey GetFileExists . fst) fileExistChanges let keys2 = map (toKey GetModificationTime . fst) fileModifChanges - return (keys1 <> keys2) + return (keys0 <> keys1 <> keys2) fromChange :: FileChangeType -> Maybe Bool fromChange FileChangeType_Created = Just True diff --git a/ghcide/src/Development/IDE/Core/FileStore.hs b/ghcide/src/Development/IDE/Core/FileStore.hs index 145e9dc905..e96a3984cf 100644 --- a/ghcide/src/Development/IDE/Core/FileStore.hs +++ b/ghcide/src/Development/IDE/Core/FileStore.hs @@ -149,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 diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index f6c23a8405..04381b65fa 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -563,10 +563,11 @@ deleteValue => ShakeExtras -> k -> NormalizedFilePath - -> STM () + -> STM [Key] deleteValue ShakeExtras{dirtyKeys, state} key file = do STM.delete (toKey key file) state - modifyTVar' dirtyKeys $ insertKeySet (toKey key file) + return [toKey key file] + recordDirtyKeys :: ShakeExtras diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 7b5fe7adeb..f5cc4abc96 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -117,8 +117,9 @@ descriptor recorder plId = (defaultPluginDescriptor plId desc) { pluginNotificat let msg = show fileEvents' logWith recorder Debug $ LogWatchedFileEvents (Text.pack msg) setSomethingModified (VFSModified vfs) ide msg $ do - resetFileStore ide fileEvents' - modifyFileExists ide fileEvents' + ks1 <- resetFileStore ide fileEvents' + ks2 <- modifyFileExists ide fileEvents' + return (ks1 <> ks2) , mkPluginNotificationHandler LSP.SMethod_WorkspaceDidChangeWorkspaceFolders $ \ide _ _ (DidChangeWorkspaceFoldersParams events) -> liftIO $ do From 48d5644a527682eba22432ec56576c00f76450fc Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 06:06:47 +0800 Subject: [PATCH 11/51] cleanup --- plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs index b9db5f816f..c13ce9fe4a 100644 --- a/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs +++ b/plugins/hls-cabal-plugin/src/Ide/Plugin/Cabal.hs @@ -6,7 +6,6 @@ module Ide.Plugin.Cabal (descriptor, Log (..)) where -import Control.Concurrent.STM import Control.Concurrent.Strict import Control.DeepSeq import Control.Lens ((^.)) From e967dde93bc66f6b692b3f5f2067e2b98c28644d Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 22:25:42 +0800 Subject: [PATCH 12/51] fix the race between cache value updated but not updated hls-database --- ghcide/src/Development/IDE/Core/Shake.hs | 9 ++++----- ghcide/src/Development/IDE/Core/Tracing.hs | 2 +- hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 4 +++- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 6 +++--- 4 files changed, 11 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 04381b65fa..0f2d376cb3 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1200,7 +1200,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do Just (v@(Succeeded _ x), diags) -> do ver <- estimateFileVersionUnsafely key (Just x) file doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags - return $ Just $ RunResult ChangedNothing old $ A v + return $ Just $ RunResult ChangedNothing old (A v) mempty _ -> return Nothing _ -> -- assert that a "clean" rule is never a cache miss @@ -1224,7 +1224,6 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do Nothing -> do pure (toShakeValue ShakeStale mbBs, staleV) Just v -> pure (maybe ShakeNoCutoff ShakeResult mbBs, Succeeded ver v) - liftIO $ atomicallyNamed "define - write" $ setValues state key file res (Vector.fromList diags) doDiagnostics (vfsVersion =<< ver) diags let eq = case (bs, fmap decodeShakeValue mbOld) of (ShakeResult a, Just (ShakeResult b)) -> cmp a b @@ -1234,9 +1233,9 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do _ -> False return $ RunResult (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) - (encodeShakeValue bs) $ - A res - liftIO $ atomicallyNamed "define - dirtyKeys" $ modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) + (encodeShakeValue bs) + (A res) + (setValues state key file res (Vector.fromList diags) >> modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)) return res where -- Highly unsafe helper to compute the version of a file diff --git a/ghcide/src/Development/IDE/Core/Tracing.hs b/ghcide/src/Development/IDE/Core/Tracing.hs index 86212f0e83..b55dcc7af5 100644 --- a/ghcide/src/Development/IDE/Core/Tracing.hs +++ b/ghcide/src/Development/IDE/Core/Tracing.hs @@ -112,7 +112,7 @@ otTracedAction key file mode result act ExitCaseSuccess res -> do setTag sp "result" (pack $ result $ runValue res) setTag sp "changed" $ case res of - RunResult x _ _ -> fromString $ show x + RunResult x _ _ _ -> fromString $ show x endSpan sp) (\sp -> act (liftIO . setTag sp "diagnostics" . encodeUtf8 . showDiagnostics )) | otherwise = act (\_ -> return ()) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 63e874c87d..8d956e74c9 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -200,7 +200,9 @@ compute db@Database{..} stack key mode result = do (getResultDepsDefault mempty previousDeps) deps _ -> pure () - atomicallyNamed "compute" $ SMap.focus (updateStatus $ Clean res) key databaseValues + atomicallyNamed "compute and run hook" $ do + runHook + SMap.focus (updateStatus $ Clean res) key databaseValues pure res updateStatus :: Monad m => Status -> Focus.Focus KeyDetails m () diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 02b5ccd4b0..227eb6ab4b 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -27,6 +27,7 @@ import qualified StmContainers.Map as SMap import StmContainers.Map (Map) import System.Time.Extra (Seconds) import UnliftIO (MonadUnliftIO) +import Control.Concurrent.STM (STM) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) @@ -202,11 +203,10 @@ data RunResult value = RunResult -- ^ The value to store in the Shake database. ,runValue :: value -- ^ The value to return from 'Development.Shake.Rule.apply'. + ,runHook :: STM () + -- ^ The value to return from 'Development.Shake.Rule.apply'. } deriving Functor -instance NFData value => NFData (RunResult value) where - rnf (RunResult x1 x2 x3) = rnf x1 `seq` x2 `seq` rnf x3 - --------------------------------------------------------------------- -- EXCEPTIONS From 69c93964c547893d346bddc7adb70e3e152d9b2d Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 22:38:45 +0800 Subject: [PATCH 13/51] fix build --- hls-graph/test/DatabaseSpec.hs | 2 +- hls-graph/test/Example.hs | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 4f15e77639..489b50fc7e 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -20,6 +20,6 @@ spec = do ruleBool addRule $ \Rule _old _mode -> do True <- apply1 (Rule @Bool) - return $ RunResult ChangedRecomputeDiff "" () + return $ RunResult ChangedRecomputeDiff "" () mempty let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) timeout 1 res `shouldThrow` \StackException{} -> True diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 2845b60e6c..2b12b3dcec 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -22,13 +22,13 @@ type instance RuleResult (Rule a) = a ruleUnit :: Rules () ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do - return $ RunResult ChangedRecomputeDiff "" () + return $ RunResult ChangedRecomputeDiff "" () mempty -- | Depends on Rule @() ruleBool :: Rules () ruleBool = addRule $ \Rule _old _mode -> do () <- apply1 Rule - return $ RunResult ChangedRecomputeDiff "" True + return $ RunResult ChangedRecomputeDiff "" True mempty data CondRule = CondRule From 02f0d41f18d5c05c0722d5535735f2e01ba3073c Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 28 Apr 2024 23:01:40 +0800 Subject: [PATCH 14/51] fix hls-graph --- hls-graph/test/ActionSpec.hs | 2 +- hls-graph/test/Example.hs | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index ffb319c614..0f4dd2627d 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -87,7 +87,7 @@ spec = do ruleUnit addRule $ \Rule _old _mode -> do [()] <- applyWithoutDependency [Rule] - return $ RunResult ChangedRecomputeDiff "" True + return $ RunResult ChangedRecomputeDiff "" True mempty let theKey = Rule @Bool res <- shakeRunDatabase db $ diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 2b12b3dcec..6c0d546684 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -39,7 +39,7 @@ type instance RuleResult CondRule = Bool ruleCond :: C.MVar Bool -> Rules () ruleCond mv = addRule $ \CondRule _old _mode -> do r <- liftIO $ C.modifyMVar mv $ \x -> return (not x, x) - return $ RunResult ChangedRecomputeDiff "" r + return $ RunResult ChangedRecomputeDiff "" r mempty data BranchedRule = BranchedRule deriving (Eq, Generic, Hashable, NFData, Show, Typeable) @@ -50,9 +50,9 @@ ruleWithCond = addRule $ \BranchedRule _old _mode -> do r <- apply1 CondRule if r then do _ <- apply1 SubBranchRule - return $ RunResult ChangedRecomputeDiff "" (1 :: Int) + return $ RunResult ChangedRecomputeDiff "" (1 :: Int) mempty else - return $ RunResult ChangedRecomputeDiff "" (2 :: Int) + return $ RunResult ChangedRecomputeDiff "" (2 :: Int) mempty data SubBranchRule = SubBranchRule deriving (Eq, Generic, Hashable, NFData, Show, Typeable) @@ -61,4 +61,4 @@ type instance RuleResult SubBranchRule = Int ruleSubBranch :: C.MVar Int -> Rules () ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do r <- liftIO $ C.modifyMVar mv $ \x -> return (x+1, x) - return $ RunResult ChangedRecomputeDiff "" r + return $ RunResult ChangedRecomputeDiff "" r mempty From c983727d29ec00132c50116a4bc0b455fe4d6a29 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 29 Apr 2024 05:24:15 +0800 Subject: [PATCH 15/51] fix 9.2.8 --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- .../src/Development/IDE/Graph/Internal/Types.hs | 2 +- hls-graph/test/ActionSpec.hs | 2 +- hls-graph/test/DatabaseSpec.hs | 2 +- hls-graph/test/Example.hs | 12 ++++++------ 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 0f2d376cb3..0d1eb3ea60 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1200,7 +1200,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do Just (v@(Succeeded _ x), diags) -> do ver <- estimateFileVersionUnsafely key (Just x) file doDiagnostics (vfsVersion =<< ver) $ Vector.toList diags - return $ Just $ RunResult ChangedNothing old (A v) mempty + return $ Just $ RunResult ChangedNothing old (A v) $ return () _ -> return Nothing _ -> -- assert that a "clean" rule is never a cache miss diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index 227eb6ab4b..e8d09359c8 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -204,7 +204,7 @@ data RunResult value = RunResult ,runValue :: value -- ^ The value to return from 'Development.Shake.Rule.apply'. ,runHook :: STM () - -- ^ The value to return from 'Development.Shake.Rule.apply'. + -- ^ The hook to run after the rule completes. } deriving Functor --------------------------------------------------------------------- diff --git a/hls-graph/test/ActionSpec.hs b/hls-graph/test/ActionSpec.hs index 0f4dd2627d..eece9b03ca 100644 --- a/hls-graph/test/ActionSpec.hs +++ b/hls-graph/test/ActionSpec.hs @@ -87,7 +87,7 @@ spec = do ruleUnit addRule $ \Rule _old _mode -> do [()] <- applyWithoutDependency [Rule] - return $ RunResult ChangedRecomputeDiff "" True mempty + return $ RunResult ChangedRecomputeDiff "" True $ return () let theKey = Rule @Bool res <- shakeRunDatabase db $ diff --git a/hls-graph/test/DatabaseSpec.hs b/hls-graph/test/DatabaseSpec.hs index 489b50fc7e..97a04d3007 100644 --- a/hls-graph/test/DatabaseSpec.hs +++ b/hls-graph/test/DatabaseSpec.hs @@ -20,6 +20,6 @@ spec = do ruleBool addRule $ \Rule _old _mode -> do True <- apply1 (Rule @Bool) - return $ RunResult ChangedRecomputeDiff "" () mempty + return $ RunResult ChangedRecomputeDiff "" () (return ()) let res = shakeRunDatabase db $ pure $ apply1 (Rule @()) timeout 1 res `shouldThrow` \StackException{} -> True diff --git a/hls-graph/test/Example.hs b/hls-graph/test/Example.hs index 6c0d546684..a15cb5487f 100644 --- a/hls-graph/test/Example.hs +++ b/hls-graph/test/Example.hs @@ -22,13 +22,13 @@ type instance RuleResult (Rule a) = a ruleUnit :: Rules () ruleUnit = addRule $ \(Rule :: Rule ()) _old _mode -> do - return $ RunResult ChangedRecomputeDiff "" () mempty + return $ RunResult ChangedRecomputeDiff "" () (return ()) -- | Depends on Rule @() ruleBool :: Rules () ruleBool = addRule $ \Rule _old _mode -> do () <- apply1 Rule - return $ RunResult ChangedRecomputeDiff "" True mempty + return $ RunResult ChangedRecomputeDiff "" True (return ()) data CondRule = CondRule @@ -39,7 +39,7 @@ type instance RuleResult CondRule = Bool ruleCond :: C.MVar Bool -> Rules () ruleCond mv = addRule $ \CondRule _old _mode -> do r <- liftIO $ C.modifyMVar mv $ \x -> return (not x, x) - return $ RunResult ChangedRecomputeDiff "" r mempty + return $ RunResult ChangedRecomputeDiff "" r (return ()) data BranchedRule = BranchedRule deriving (Eq, Generic, Hashable, NFData, Show, Typeable) @@ -50,9 +50,9 @@ ruleWithCond = addRule $ \BranchedRule _old _mode -> do r <- apply1 CondRule if r then do _ <- apply1 SubBranchRule - return $ RunResult ChangedRecomputeDiff "" (1 :: Int) mempty + return $ RunResult ChangedRecomputeDiff "" (1 :: Int) (return ()) else - return $ RunResult ChangedRecomputeDiff "" (2 :: Int) mempty + return $ RunResult ChangedRecomputeDiff "" (2 :: Int) (return ()) data SubBranchRule = SubBranchRule deriving (Eq, Generic, Hashable, NFData, Show, Typeable) @@ -61,4 +61,4 @@ type instance RuleResult SubBranchRule = Int ruleSubBranch :: C.MVar Int -> Rules () ruleSubBranch mv = addRule $ \SubBranchRule _old _mode -> do r <- liftIO $ C.modifyMVar mv $ \x -> return (x+1, x) - return $ RunResult ChangedRecomputeDiff "" r mempty + return $ RunResult ChangedRecomputeDiff "" r (return ()) From 3748fc2f0e0f5ebb9cd8af30740a45754186f166 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 29 Apr 2024 08:36:30 +0800 Subject: [PATCH 16/51] format --- hls-graph/src/Development/IDE/Graph/Internal/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs index e8d09359c8..3474289b42 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs @@ -5,6 +5,7 @@ module Development.IDE.Graph.Internal.Types where +import Control.Concurrent.STM (STM) import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Trans.Reader @@ -27,7 +28,6 @@ import qualified StmContainers.Map as SMap import StmContainers.Map (Map) import System.Time.Extra (Seconds) import UnliftIO (MonadUnliftIO) -import Control.Concurrent.STM (STM) #if !MIN_VERSION_base(4,18,0) import Control.Applicative (liftA2) From a65ac5c15fc8d6d5a2456b805a61ccd464b862f7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 1 May 2024 18:19:22 +0800 Subject: [PATCH 17/51] run refreshDeps in a single asyncWithCleanUp --- .../Development/IDE/Graph/Internal/Database.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs index 8d956e74c9..7f2cee0a8c 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs @@ -143,31 +143,31 @@ isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep) -- * If no dirty dependencies and we have evaluated the key previously, then we refresh it in the current thread. -- This assumes that the implementation will be a lookup -- * Otherwise, we spawn a new thread to refresh the dirty deps (if any) and the key itself -refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result) +refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO Result refreshDeps visited db stack key result = \case -- no more deps to refresh - [] -> pure $ compute db stack key RunDependenciesSame (Just result) + [] -> liftIO $ compute db stack key RunDependenciesSame (Just result) (dep:deps) -> do let newVisited = dep <> visited res <- builder db stack (toListKeySet (dep `differenceKeySet` visited)) case res of Left res -> if isDirty result res -- restart the computation if any of the deps are dirty - then asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged (Just result) + then liftIO $ compute db stack key RunDependenciesChanged (Just result) -- else kick the rest of the deps else refreshDeps newVisited db stack key result deps - Right iores -> asyncWithCleanUp $ liftIO $ do - res <- iores + Right iores -> do + res <- liftIO iores if isDirty result res - then compute db stack key RunDependenciesChanged (Just result) - else join $ runAIO $ refreshDeps newVisited db stack key result deps + then liftIO $ compute db stack key RunDependenciesChanged (Just result) + else refreshDeps newVisited db stack key result deps -- | Refresh a key: refresh :: Database -> Stack -> Key -> Maybe Result -> AIO (IO Result) -- refresh _ st k _ | traceShow ("refresh", st, k) False = undefined refresh db stack key result = case (addStack key stack, result) of (Left e, _) -> throw e - (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps) + (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> asyncWithCleanUp $ refreshDeps mempty db stack key me (reverse deps) (Right stack, _) -> asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result From f4690c577cea0a31d3a956aa080c5bb9c5b4da52 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 1 May 2024 23:35:21 +0800 Subject: [PATCH 18/51] shut the session before shut the reactor --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index e4493436cb..19f2d93b16 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -262,10 +262,10 @@ shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do (_, ide) <- ask liftIO $ logWith recorder Debug LogServerShutdownMessage - -- stop the reactor to free up the hiedb connection - liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide + -- stop the reactor to free up the hiedb connection + liftIO stopReactor resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) From 610355cb00ed350ff510d0010ac67fcfd2d2a7e4 Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 05:02:48 +0800 Subject: [PATCH 19/51] Revert "shut the session before shut the reactor" This reverts commit f4690c577cea0a31d3a956aa080c5bb9c5b4da52. --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 19f2d93b16..e4493436cb 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -262,10 +262,10 @@ shutdownHandler :: Recorder (WithPriority Log) -> IO () -> LSP.Handlers (ServerM shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ resp -> do (_, ide) <- ask liftIO $ logWith recorder Debug LogServerShutdownMessage - -- flush out the Shake session to record a Shake profile if applicable - liftIO $ shakeShut ide -- stop the reactor to free up the hiedb connection liftIO stopReactor + -- flush out the Shake session to record a Shake profile if applicable + liftIO $ shakeShut ide resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) From 63b1956d34e3f8c64695f663ae6276f22aa60f0b Mon Sep 17 00:00:00 2001 From: Patrick Date: Fri, 3 May 2024 06:25:10 +0800 Subject: [PATCH 20/51] remove record dirty key recordDirtyKeys --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- ghcide/src/Development/IDE/Core/Shake.hs | 13 ++----------- 2 files changed, 4 insertions(+), 13 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index d93f654e21..2d12125b7b 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -613,10 +613,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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" [] $ do - key1 <- extendKnownTargets all_targets - key2 <- invalidateShakeCache return [key1, key2] -- Invalidate all the existing GhcSession build nodes by restarting the Shake session diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 0d1eb3ea60..3973a8a3e8 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -57,7 +57,7 @@ module Development.IDE.Core.Shake( FileVersion(..), updatePositionMapping, updatePositionMappingHelper, - deleteValue, recordDirtyKeys, + deleteValue, WithProgressFunc, WithIndefiniteProgressFunc, ProgressEvent(..), DelayedAction, mkDelayedAction, @@ -569,15 +569,6 @@ deleteValue ShakeExtras{dirtyKeys, state} key file = do return [toKey key file] -recordDirtyKeys - :: ShakeExtras - -> [Key] - -> STM (IO ()) -recordDirtyKeys ShakeExtras{dirtyKeys} keys = do - modifyTVar' dirtyKeys $ \x -> foldl' (flip insertKeySet) x keys - return $ withEventTrace "recordDirtyKeys" $ \addEvent -> do - addEvent (fromString $ unlines $ "dirty " : map show keys) - -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value. getValues :: forall k v. @@ -766,7 +757,7 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner keys <- ioActionBetweenShakeSession - join $ atomically $ recordDirtyKeys shakeExtras keys + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras From 742369525cacf1b09054ad8ee6d6366f7b772495 Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 6 May 2024 20:36:49 +0800 Subject: [PATCH 21/51] Update ghcide/src/Development/IDE/Core/Shake.hs Co-authored-by: Jan Hrcek <2716069+jhrcek@users.noreply.github.com> --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 3973a8a3e8..16e96af6eb 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -564,7 +564,7 @@ deleteValue -> k -> NormalizedFilePath -> STM [Key] -deleteValue ShakeExtras{dirtyKeys, state} key file = do +deleteValue ShakeExtras{state} key file = do STM.delete (toKey key file) state return [toKey key file] From 0c4a2f574a859d30471cbd816ccf1965cce4131a Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 6 May 2024 20:37:15 +0800 Subject: [PATCH 22/51] Update ghcide/src/Development/IDE/Core/FileExists.hs Co-authored-by: Jan Hrcek <2716069+jhrcek@users.noreply.github.com> --- ghcide/src/Development/IDE/Core/FileExists.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 28c633f93d..a0d5b2ac84 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -120,7 +120,7 @@ modifyFileExists state changes = do -- flush previous values let (fileModifChanges, fileExistChanges) = partition ((== FileChangeType_Changed) . snd) changes - keys0 <- concat <$> mapM (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges + keys0 <- foldMap (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges let keys1 = map (toKey GetFileExists . fst) fileExistChanges let keys2 = map (toKey GetModificationTime . fst) fileModifChanges return (keys0 <> keys1 <> keys2) From bea88b51aee5a4d7f9b7a4dcba7246754e9a693d Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 6 May 2024 20:37:33 +0800 Subject: [PATCH 23/51] Update ghcide/session-loader/Development/IDE/Session.hs Co-authored-by: Jan Hrcek <2716069+jhrcek@users.noreply.github.com> --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 2d12125b7b..4d6de699a1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -518,7 +518,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do return (pure hasUpdate) for_ hasUpdate $ \x -> logWith recorder Debug $ LogKnownFilesUpdated x - return $ toKey GetKnownTargets emptyFilePath + return $ toNoFileKey GetKnownTargets -- Create a new HscEnv from a hieYaml root and a set of options let packageSetup :: (Maybe FilePath, NormalizedFilePath, ComponentOptions, FilePath) From c9219f0b18189b56f63b14a82715bdfecd62214a Mon Sep 17 00:00:00 2001 From: soulomoon Date: Mon, 6 May 2024 20:37:55 +0800 Subject: [PATCH 24/51] Update ghcide/session-loader/Development/IDE/Session.hs Co-authored-by: Jan Hrcek <2716069+jhrcek@users.noreply.github.com> --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 4d6de699a1..ea2eecb088 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -476,7 +476,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do } <- getShakeExtras let invalidateShakeCache = do void $ modifyVar' version succ - return $ toKey GhcSessionIO emptyFilePath + return $ toNoFileKey GhcSessionIO IdeOptions{ optTesting = IdeTesting optTesting , optCheckProject = getCheckProject From 7a08b0332810268057b98d843cd087e80019387f Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 6 May 2024 20:45:14 +0800 Subject: [PATCH 25/51] cleanup --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- ghcide/src/Development/IDE/Core/FileExists.hs | 2 +- ghcide/src/Development/IDE/Core/Shake.hs | 5 +++-- ghcide/src/Development/IDE/Main.hs | 3 +-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index ea2eecb088..bbead3219e 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -509,13 +509,13 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do TargetModule _ -> do found <- filterM (IO.doesFileExist . fromNormalizedFilePath) targetLocations return [(targetTarget, Set.fromList found)] - hasUpdate <- join $ atomically $ do + hasUpdate <- atomically $ do known <- readTVar knownTargetsVar let known' = flip mapHashed known $ \k -> HM.unionWith (<>) k $ HM.fromList knownTargets hasUpdate = if known /= known' then Just (unhashed known') else Nothing writeTVar knownTargetsVar known' - return (pure hasUpdate) + pure hasUpdate for_ hasUpdate $ \x -> logWith recorder Debug $ LogKnownFilesUpdated x return $ toNoFileKey GetKnownTargets diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index a0d5b2ac84..52527622d2 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -106,7 +106,7 @@ getFileExistsMapUntracked = do FileExistsMapVar v <- getIdeGlobalAction return v --- | Modify the global store of file exists. +-- | Modify the global store of file exists and return the keys that need to be mark as dirty modifyFileExists :: IdeState -> [(NormalizedFilePath, FileChangeType)] -> IO [Key] modifyFileExists state changes = do FileExistsMapVar var <- getIdeGlobalState state diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 16e96af6eb..bd9b9e887d 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -1225,8 +1225,9 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do return $ RunResult (if eq then ChangedRecomputeSame else ChangedRecomputeDiff) (encodeShakeValue bs) - (A res) - (setValues state key file res (Vector.fromList diags) >> modifyTVar' dirtyKeys (deleteKeySet $ toKey key file)) + (A res) $ do + setValues state key file res (Vector.fromList diags) + modifyTVar' dirtyKeys (deleteKeySet $ toKey key file) return res where -- Highly unsafe helper to compute the version of a file diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index b9c977e08e..1eb3cbe73b 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -18,8 +18,7 @@ import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Exception.Safe (SomeException, catchAny, displayException) -import Control.Monad.Extra (concatMapM, join, - unless, when) +import Control.Monad.Extra (concatMapM, unless, when) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as J import Data.Coerce (coerce) From dc18b7479467b0d39c6253757504c27a7b82541c Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 6 May 2024 20:49:23 +0800 Subject: [PATCH 26/51] fix --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index bbead3219e..5e0b1924e1 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -106,7 +106,7 @@ import qualified Data.HashSet as Set import Database.SQLite.Simple import Development.IDE.Core.Tracing (withTrace) import Development.IDE.Session.Diagnostics (renderCradleError) -import Development.IDE.Types.Shake (WithHieDb, toKey) +import Development.IDE.Types.Shake (WithHieDb, toNoFileKey) import HieDb.Create import HieDb.Types import HieDb.Utils From dc71a4074fe215a6111bedc8bbb0338e72675012 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 6 May 2024 20:53:49 +0800 Subject: [PATCH 27/51] cleanup --- ghcide/session-loader/Development/IDE/Session.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 5e0b1924e1..0a2126f43f 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -614,11 +614,11 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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. + -- Invalidate all the existing GhcSession build nodes by restarting the Shake session restartShakeSession VFSUnmodified "new component" [] $ do + key2 <- invalidateShakeCache 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 From 342f52fb955d479f64511ced3c766e7648ac8ffd Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 6 May 2024 21:34:42 +0800 Subject: [PATCH 28/51] fix ghc 9.2 --- ghcide/src/Development/IDE/Core/FileExists.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/FileExists.hs b/ghcide/src/Development/IDE/Core/FileExists.hs index 52527622d2..39c663cd8e 100644 --- a/ghcide/src/Development/IDE/Core/FileExists.hs +++ b/ghcide/src/Development/IDE/Core/FileExists.hs @@ -120,7 +120,7 @@ modifyFileExists state changes = do -- flush previous values let (fileModifChanges, fileExistChanges) = partition ((== FileChangeType_Changed) . snd) changes - keys0 <- foldMap (deleteValue (shakeExtras state) GetFileExists . fst) fileExistChanges + 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) From 240254e9cdaf4f392b08b7b30ddd9e1eab19d369 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 6 May 2024 21:55:09 +0800 Subject: [PATCH 29/51] stylish --- ghcide/src/Development/IDE/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 1eb3cbe73b..014aec8d71 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -18,7 +18,8 @@ import Control.Concurrent.STM.Stats (dumpSTMStats) import Control.Exception.Safe (SomeException, catchAny, displayException) -import Control.Monad.Extra (concatMapM, unless, when) +import Control.Monad.Extra (concatMapM, unless, + when) import Control.Monad.IO.Class (liftIO) import qualified Data.Aeson as J import Data.Coerce (coerce) From 3bb1e1bec0b573ced2c24aa84583482d64e59ea2 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 7 May 2024 02:07:18 +0800 Subject: [PATCH 30/51] thread shake restart to a worker thread --- ghcide/src/Development/IDE/Core/Service.hs | 23 +++++++++++++++++-- ghcide/src/Development/IDE/Core/Shake.hs | 11 ++++++++- .../src/Development/IDE/LSP/LanguageServer.hs | 14 ++++++----- ghcide/src/Development/IDE/Main.hs | 19 ++++++++------- 4 files changed, 50 insertions(+), 17 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index cdb5ba72cb..f5c747bf9c 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -9,6 +9,8 @@ module Development.IDE.Core.Service( getIdeOptions, getIdeOptionsIO, IdeState, initialise, shutdown, + runWithShake, + ShakeOpQueue, runAction, getDiagnostics, ideLogger, @@ -31,6 +33,10 @@ import Ide.Plugin.Config import qualified Language.LSP.Protocol.Types as LSP import qualified Language.LSP.Server as LSP +import Control.Concurrent.Async (async, withAsync) +import Control.Concurrent.STM (TQueue, atomically, + newTQueueIO, readTQueue, + writeTBQueue, writeTQueue) import Control.Monad import qualified Development.IDE.Core.FileExists as FileExists import qualified Development.IDE.Core.OfInterest as OfInterest @@ -66,9 +72,10 @@ initialise :: Recorder (WithPriority Log) -> IdeOptions -> WithHieDb -> IndexQueue + -> ShakeOpQueue -> Monitoring -> IO IdeState -initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan metrics = do +initialise recorder defaultConfig plugins mainRule lspEnv debouncer options withHieDb hiedbChan sq metrics = do shakeProfiling <- do let fromConf = optShakeProfiling options fromEnv <- lookupEnv "GHCIDE_BUILD_PROFILING" @@ -84,6 +91,7 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with (optTesting options) withHieDb hiedbChan + sq (optShakeOptions options) metrics $ do @@ -94,7 +102,7 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with -- | Shutdown the Compiler Service. shutdown :: IdeState -> IO () -shutdown = shakeShut +shutdown st = atomically $ writeTQueue (shakeOpQueue $ shakeExtras st) $ shakeShut st -- This will return as soon as the result of the action is -- available. There might still be other rules running at this point, @@ -102,3 +110,14 @@ shutdown = shakeShut runAction :: String -> IdeState -> Action a -> IO a runAction herald ide act = join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug act) + + +runWithShake :: (ShakeOpQueue-> IO ()) -> IO () +runWithShake f = do + q <- newTQueueIO + withAsync (runShakeOp q) $ const $ f q + where + runShakeOp :: ShakeOpQueue -> IO () + runShakeOp q = do + join $ atomically $ readTQueue q + runShakeOp q diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index bd9b9e887d..0dc19e059c 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -29,6 +29,7 @@ module Development.IDE.Core.Shake( GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), shakeOpen, shakeShut, shakeEnqueue, + ShakeOpQueue, newSession, use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction, FastResult(..), @@ -77,6 +78,7 @@ module Development.IDE.Core.Shake( import Control.Concurrent.Async import Control.Concurrent.STM +import Control.Concurrent.STM (writeTQueue) import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq @@ -257,6 +259,10 @@ data HieDbWriter -- with (currently) retry functionality type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) +-- ShakeOpQueue is used to enqueue Shake operations. +-- shutdown, restart +type ShakeOpQueue = TQueue (IO ()) + -- Note [Semantic Tokens Cache Location] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- storing semantic tokens cache for each file in shakeExtras might @@ -329,6 +335,7 @@ data ShakeExtras = ShakeExtras -- ^ Default HLS config, only relevant if the client does not provide any Config , dirtyKeys :: TVar KeySet -- ^ Set of dirty rule keys since the last Shake run + , shakeOpQueue :: ShakeOpQueue } type WithProgressFunc = forall a. @@ -614,6 +621,7 @@ shakeOpen :: Recorder (WithPriority Log) -> IdeTesting -> WithHieDb -> IndexQueue + -> ShakeOpQueue -> ShakeOptions -> Monitoring -> Rules () @@ -621,7 +629,7 @@ shakeOpen :: Recorder (WithPriority Log) shakeOpen recorder lspEnv defaultConfig idePlugins debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) - withHieDb indexQueue opts monitoring rules = mdo + withHieDb indexQueue shakeOpQueue opts monitoring rules = mdo #if MIN_VERSION_ghc(9,3,0) ideNc <- initNameCache 'r' knownKeyNames @@ -752,6 +760,7 @@ delayedAction a = do -- but actions added via 'shakeEnqueue' will be requeued. shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = + atomically $ writeTQueue (shakeOpQueue $ shakeExtras) $ withMVar' shakeSession (\runner -> do diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index e4493436cb..60145ff253 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -34,6 +34,8 @@ import UnliftIO.Exception import qualified Colog.Core as Colog import Control.Monad.IO.Unlift (MonadUnliftIO) import Development.IDE.Core.IdeConfiguration +import Development.IDE.Core.Service (ShakeOpQueue, + runWithShake) import Development.IDE.Core.Shake hiding (Log, Priority) import Development.IDE.Core.Tracing import qualified Development.IDE.Session as Session @@ -128,7 +130,7 @@ setupLSP :: Recorder (WithPriority Log) -> (FilePath -> IO FilePath) -- ^ Map root paths to the location of the hiedb for the project -> LSP.Handlers (ServerM config) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> ShakeOpQueue -> IO IdeState) -> MVar () -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), @@ -186,7 +188,7 @@ setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do handleInit :: Recorder (WithPriority Log) -> (FilePath -> IO FilePath) - -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState) + -> (LSP.LanguageContextEnv config -> Maybe FilePath -> WithHieDb -> IndexQueue -> ShakeOpQueue -> IO IdeState) -> MVar () -> IO () -> (SomeLspId -> IO ()) @@ -228,8 +230,8 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa exceptionInHandler e k $ ResponseError (InR ErrorCodes_InternalError) (T.pack $ show e) Nothing _ <- flip forkFinally handleServerException $ do - untilMVar lifetime $ runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do - putMVar dbMVar (WithHieDbShield withHieDb',hieChan') + untilMVar lifetime $ runWithShake $ \sq -> runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \withHieDb' hieChan' -> do + putMVar dbMVar (WithHieDbShield withHieDb',hieChan',sq) forever $ do msg <- readChan clientMsgChan -- We dispatch notifications synchronously and requests asynchronously @@ -239,8 +241,8 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped - (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar - ide <- getIdeState env root withHieDb hieChan + (WithHieDbShield withHieDb,hieChan,sq) <- takeMVar dbMVar + ide <- getIdeState env root withHieDb hieChan sq registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 014aec8d71..53ecc7c6ad 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -51,8 +51,10 @@ import qualified Development.IDE.Core.Rules as Rules import Development.IDE.Core.RuleTypes (GenerateCore (GenerateCore), GetHieAst (GetHieAst), TypeCheck (TypeCheck)) -import Development.IDE.Core.Service (initialise, - runAction) +import Development.IDE.Core.Service (ShakeOpQueue, + initialise, + runAction, + runWithShake) import qualified Development.IDE.Core.Service as Service import Development.IDE.Core.Shake (IdeState (shakeExtras), IndexQueue, @@ -309,8 +311,8 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re logWith recorder Info $ LogLspStart (pluginId <$> ipMap argsHlsPlugins) ideStateVar <- newEmptyMVar - let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> IO IdeState - getIdeState env rootPath withHieDb hieChan = do + let getIdeState :: LSP.LanguageContextEnv Config -> Maybe FilePath -> WithHieDb -> IndexQueue -> ShakeOpQueue -> IO IdeState + getIdeState env rootPath withHieDb hieChan sq = do traverse_ IO.setCurrentDirectory rootPath t <- ioT logWith recorder Info $ LogLspStartDuration t @@ -349,6 +351,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re ideOptions withHieDb hieChan + sq monitoring putMVar ideStateVar ide pure ide @@ -373,7 +376,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Check argFiles -> do dir <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc dir - runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do + runWithShake $ \sq -> runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error hSetEncoding stdout utf8 hSetEncoding stderr utf8 @@ -401,7 +404,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan sq mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) @@ -431,7 +434,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re Custom (IdeCommand c) -> do root <- maybe IO.getCurrentDirectory return argsProjectRoot dbLoc <- getHieDbLoc root - runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do + runWithShake $ \sq -> runWithDb (cmapWithPrio LogSession recorder) dbLoc $ \hiedb hieChan -> do sessionLoader <- loadSessionWithOptions (cmapWithPrio LogSession recorder) argsSessionLoadingOptions "." let def_options = argsIdeOptions argsDefaultHlsConfig sessionLoader ideOptions = def_options @@ -439,7 +442,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re , optCheckProject = pure False , optModifyDynFlags = optModifyDynFlags def_options <> pluginModifyDynflags plugins } - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan mempty + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig argsHlsPlugins rules Nothing debouncer ideOptions hiedb hieChan sq mempty shakeSessionInit (cmapWithPrio LogShake recorder) ide registerIdeConfiguration (shakeExtras ide) $ IdeConfiguration mempty (hashed Nothing) c ide From f8220baac6e0419b9328ecf3132c4979425a6ab7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 7 May 2024 03:03:30 +0800 Subject: [PATCH 31/51] wait for cancel --- ghcide/src/Development/IDE/Core/Shake.hs | 52 +++++++++++++----------- 1 file changed, 28 insertions(+), 24 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 0dc19e059c..05ab86cbcb 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -174,6 +174,7 @@ import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra +import Control.Concurrent.Extra (signalBarrier) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) @@ -759,31 +760,34 @@ delayedAction a = do -- Any actions running in the current session will be aborted, -- but actions added via 'shakeEnqueue' will be requeued. shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = +shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = do + barrier <- newBarrier atomically $ writeTQueue (shakeOpQueue $ shakeExtras) $ - withMVar' - shakeSession - (\runner -> do - (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - keys <- ioActionBetweenShakeSession - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys - res <- shakeDatabaseProfile shakeDb - backlog <- readTVarIO $ dirtyKeys shakeExtras - queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras - - -- this log is required by tests - logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res - ) - -- It is crucial to be masked here, otherwise we can get killed - -- between spawning the new thread and updating shakeSession. - -- See https://github.com/haskell/ghcide/issues/79 - (\() -> do - (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) - where - logErrorAfter :: Seconds -> IO () -> IO () - logErrorAfter seconds action = flip withAsync (const action) $ do - sleep seconds - logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) + withMVar' + shakeSession + (\runner -> do + signalBarrier barrier () + (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + keys <- ioActionBetweenShakeSession + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + res <- shakeDatabaseProfile shakeDb + backlog <- readTVarIO $ dirtyKeys shakeExtras + queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras + + -- this log is required by tests + logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res + ) + -- It is crucial to be masked here, otherwise we can get killed + -- between spawning the new thread and updating shakeSession. + -- See https://github.com/haskell/ghcide/issues/79 + (\() -> do + (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) + waitBarrier barrier + where + logErrorAfter :: Seconds -> IO () -> IO () + logErrorAfter seconds action = flip withAsync (const action) $ do + sleep seconds + logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) -- | Enqueue an action in the existing 'ShakeSession'. -- Returns a computation to block until the action is run, propagating exceptions. From 013650b8dcfb810e3e1fdb7d0000929bed646153 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 7 May 2024 03:09:12 +0800 Subject: [PATCH 32/51] wait for cancel --- ghcide/src/Development/IDE/Core/Shake.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 05ab86cbcb..a112923fe9 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -77,6 +77,7 @@ module Development.IDE.Core.Shake( ) where import Control.Concurrent.Async +import Control.Concurrent.Extra (signalBarrier) import Control.Concurrent.STM import Control.Concurrent.STM (writeTQueue) import Control.Concurrent.STM.Stats (atomicallyNamed) @@ -174,7 +175,6 @@ import qualified StmContainers.Map as STM import System.FilePath hiding (makeRelative) import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra -import Control.Concurrent.Extra (signalBarrier) -- See Note [Guidelines For Using CPP In GHCIDE Import Statements] #if !MIN_VERSION_ghc(9,3,0) @@ -766,8 +766,8 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = withMVar' shakeSession (\runner -> do - signalBarrier barrier () (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + signalBarrier barrier () keys <- ioActionBetweenShakeSession atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys res <- shakeDatabaseProfile shakeDb From e10d13535b18f933196512d1679f0759867e3802 Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 7 May 2024 05:45:03 +0800 Subject: [PATCH 33/51] push known targets back to session restart --- ghcide/session-loader/Development/IDE/Session.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 0a2126f43f..842bddf91a 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -613,10 +613,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do 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 -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session restartShakeSession VFSUnmodified "new component" [] $ do + key1 <- extendKnownTargets all_targets key2 <- invalidateShakeCache return [key1, key2] From 39a45a2139b0f02b61c153f5adf5b240e57720fb Mon Sep 17 00:00:00 2001 From: Patrick Date: Tue, 7 May 2024 06:55:38 +0800 Subject: [PATCH 34/51] wait for the session to be restarted --- ghcide/src/Development/IDE/Core/Shake.hs | 4 ++-- ghcide/src/Development/IDE/Main.hs | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index a112923fe9..322c71181c 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -762,12 +762,11 @@ delayedAction a = do shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = do barrier <- newBarrier - atomically $ writeTQueue (shakeOpQueue $ shakeExtras) $ + atomically $ writeTQueue (shakeOpQueue $ shakeExtras) $ do withMVar' shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - signalBarrier barrier () keys <- ioActionBetweenShakeSession atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys res <- shakeDatabaseProfile shakeDb @@ -782,6 +781,7 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = -- See https://github.com/haskell/ghcide/issues/79 (\() -> do (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) + signalBarrier barrier () waitBarrier barrier where logErrorAfter :: Seconds -> IO () -> IO () diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 53ecc7c6ad..5126f4b0be 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -341,6 +341,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re } caps = LSP.resClientCapabilities env monitoring <- argsMonitoring + ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig From 6d34bacaa48fc027a6c876b052efdc757a3484e8 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 8 May 2024 03:24:06 +0800 Subject: [PATCH 35/51] split to restarting to stoping thread and starting thread --- ghcide/src/Development/IDE/Core/Service.hs | 22 ++-- ghcide/src/Development/IDE/Core/Shake.hs | 144 +++++++++++++++++---- 2 files changed, 127 insertions(+), 39 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index f5c747bf9c..1d7fdc0499 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -35,15 +35,22 @@ import qualified Language.LSP.Server as LSP import Control.Concurrent.Async (async, withAsync) import Control.Concurrent.STM (TQueue, atomically, - newTQueueIO, readTQueue, - writeTBQueue, writeTQueue) + flushTQueue, newTQueueIO, + readTQueue, writeTBQueue, + writeTQueue) import Control.Monad +import qualified Data.List.NonEmpty as NE +import Data.Semigroup (Semigroup (sconcat)) +import qualified Data.Text as T +import Debug.Trace (traceM) import qualified Development.IDE.Core.FileExists as FileExists import qualified Development.IDE.Core.OfInterest as OfInterest import Development.IDE.Core.Shake hiding (Log) import qualified Development.IDE.Core.Shake as Shake import Development.IDE.Types.Monitoring (Monitoring) import Development.IDE.Types.Shake (WithHieDb) +import Extra (sleep) +import Ide.Logger (Priority (Info), logWith) import Ide.Types (IdePlugins) import System.Environment (lookupEnv) @@ -102,7 +109,7 @@ initialise recorder defaultConfig plugins mainRule lspEnv debouncer options with -- | Shutdown the Compiler Service. shutdown :: IdeState -> IO () -shutdown st = atomically $ writeTQueue (shakeOpQueue $ shakeExtras st) $ shakeShut st +shutdown st = shakeShut st -- This will return as soon as the result of the action is -- available. There might still be other rules running at this point, @@ -112,12 +119,3 @@ runAction herald ide act = join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug act) -runWithShake :: (ShakeOpQueue-> IO ()) -> IO () -runWithShake f = do - q <- newTQueueIO - withAsync (runShakeOp q) $ const $ f q - where - runShakeOp :: ShakeOpQueue -> IO () - runShakeOp q = do - join $ atomically $ readTQueue q - runShakeOp q diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 322c71181c..4a5c137125 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -25,9 +25,10 @@ module Development.IDE.Core.Shake( IdeState, shakeSessionInit, shakeExtras, shakeDb, ShakeExtras(..), getShakeExtras, getShakeExtrasRules, KnownTargets, Target(..), toKnownFiles, - IdeRule, IdeResult, + IdeRule, IdeResult, restartRecorder, GetModificationTime(GetModificationTime, GetModificationTime_, missingFileDiagnostics), - shakeOpen, shakeShut, + shakeOpen, shakeShut, runWithShake, + doShakeRestart, shakeEnqueue, ShakeOpQueue, newSession, @@ -106,10 +107,12 @@ import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet -import Data.List.Extra (foldl', partition, - takeEnd) +import Data.List.Extra (foldl', intercalate, + partition, takeEnd) +import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe +import Data.Semigroup (Semigroup (sconcat)) import qualified Data.SortedList as SL import Data.String (fromString) import qualified Data.Text as T @@ -120,6 +123,7 @@ import Data.Typeable import Data.Unique import Data.Vector (Vector) import qualified Data.Vector as Vector +import Debug.Trace (traceM) import Development.IDE.Core.Debouncer import Development.IDE.Core.FileUtils (getModTime) import Development.IDE.Core.PositionMapping @@ -196,6 +200,7 @@ data Log | LogCancelledAction !T.Text | LogSessionInitialised | LogLookupPersistentKey !T.Text + | LogRestartDebounceCount !Int | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] @@ -242,6 +247,8 @@ instance Pretty Log where LogSetFilesOfInterest ofInterest -> "Set files of interst to" <> Pretty.line <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) + LogRestartDebounceCount count -> + "Restart debounce count:" <+> pretty count -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -262,7 +269,7 @@ type IndexQueue = TQueue (((HieDb -> IO ()) -> IO ()) -> IO ()) -- ShakeOpQueue is used to enqueue Shake operations. -- shutdown, restart -type ShakeOpQueue = TQueue (IO ()) +type ShakeOpQueue = TQueue RestartArguments -- Note [Semantic Tokens Cache Location] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -756,38 +763,118 @@ delayedAction a = do extras <- ask liftIO $ shakeEnqueue extras a --- | Restart the current 'ShakeSession' with the given system actions. --- Any actions running in the current session will be aborted, --- but actions added via 'shakeEnqueue' will be requeued. -shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () -shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = do - barrier <- newBarrier - atomically $ writeTQueue (shakeOpQueue $ shakeExtras) $ do - withMVar' - shakeSession +data RestartArguments = RestartArguments + { restartVFS :: VFSModified + , restartReasons :: [String] + , restartActions :: [DelayedAction ()] + , restartActionBetweenShakeSession :: IO [Key] + -- barrier to wait for the session stopped + , restartBarriers :: [Barrier ()] + , restartRecorder :: Recorder (WithPriority Log) + , restartIdeState :: IdeState + } + +instance Semigroup RestartArguments where + RestartArguments a1 a2 a3 a4 a5 a6 a7 <> RestartArguments b1 b2 b3 b4 b5 b6 _b7 = + RestartArguments (a1 <> b1) (a2 <> b2) (a3 <> b3) (a4 <> b4) (a5 <> b5) (a6 <> b6) a7 + +-- do x until time up and do y +-- doUntil time out +doUntil :: IO a -> IO [a] +doUntil x = do + res <- x + rest <- doUntil x + return (res:rest) + +runWithShake :: (ShakeOpQueue-> IO ()) -> IO () +runWithShake f = do + stopQueue <- newTQueueIO + doQueue <- newTQueueIO + withAsync (stopShakeLoop stopQueue doQueue) $ + const $ withAsync (runShakeLoop doQueue) $ + const $ f stopQueue + where + -- keep running the stopShakeOp and stop the shake session + -- and send the restart arguments to the runShakeLoop + stopShakeLoop :: ShakeOpQueue -> ShakeOpQueue -> IO () + stopShakeLoop stopq doq = do + arg <- atomically $ readTQueue stopq + -- todo print this out + _stopTime <- stopShakeSession arg + traceM $ "Stopped shake session" + atomically $ writeTQueue doq arg + stopShakeLoop stopq doq + runShakeLoop :: ShakeOpQueue -> IO () + runShakeLoop q = do + sleep 0.1 + x <- atomically (tryPeekTQueue q) + when (isJust x) $ do + sleep 0.1 + args <- atomically $ flushTQueue q + traceM $ "Restarting shake with " ++ show (length args) ++ " arguments" + case NE.nonEmpty args of + Nothing -> return () + Just x -> do + let count = length x + let arg = sconcat x + let recorder = restartRecorder arg + logWith recorder Info $ LogRestartDebounceCount count + -- traceM $ "Restarting shake with " ++ show count ++ " arguments" + doShakeRestart arg 1 + runShakeLoop q + +-- prepare the restart +stopShakeSession :: RestartArguments -> IO Seconds +stopShakeSession RestartArguments{restartIdeState=IdeState{..}, ..} = do + withMVar shakeSession + (\runner -> do + (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + keys <- restartActionBetweenShakeSession + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys + -- signal the caller that we are done stopping and ready to restart + mapM_ (flip signalBarrier ()) restartBarriers + return stopTime + ) + where + logErrorAfter :: Seconds -> IO () -> IO () + logErrorAfter seconds action = flip withAsync (const action) $ do + sleep seconds + logWith restartRecorder Error (LogBuildSessionRestartTakingTooLong seconds) + + +doShakeRestart :: RestartArguments -> Seconds -> IO () +doShakeRestart RestartArguments{restartIdeState=IdeState{..}, ..} stopTime = do + withMVar' shakeSession (\runner -> do - (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - keys <- ioActionBetweenShakeSession - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras - -- this log is required by tests - logWith recorder Debug $ LogBuildSessionRestart reason queue backlog stopTime res + logWith restartRecorder Debug $ LogBuildSessionRestart (intercalate ", " restartReasons) queue backlog stopTime res ) -- It is crucial to be masked here, otherwise we can get killed -- between spawning the new thread and updating shakeSession. -- See https://github.com/haskell/ghcide/issues/79 (\() -> do - (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason) - signalBarrier barrier () - waitBarrier barrier - where - logErrorAfter :: Seconds -> IO () -> IO () - logErrorAfter seconds action = flip withAsync (const action) $ do - sleep seconds - logWith recorder Error (LogBuildSessionRestartTakingTooLong seconds) + (,()) <$> newSession restartRecorder shakeExtras restartVFS shakeDb restartActions (intercalate ", " restartReasons)) + + +-- | Restart the current 'ShakeSession' with the given system actions. +-- Any actions running in the current session will be aborted, +-- but actions added via 'shakeEnqueue' will be requeued. +shakeRestart :: Recorder (WithPriority Log) -> IdeState -> VFSModified -> String -> [DelayedAction ()] -> IO [Key] -> IO () +shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = do + barrier <- newBarrier + let restartArgs = RestartArguments + { restartVFS = vfs + , restartReasons = [reason] + , restartActions = acts + , restartActionBetweenShakeSession = ioActionBetweenShakeSession + , restartBarriers = [barrier] + , restartRecorder = recorder + , restartIdeState = IdeState{..} + } + atomically $ writeTQueue (shakeOpQueue $ shakeExtras) restartArgs -- | Enqueue an action in the existing 'ShakeSession'. -- Returns a computation to block until the action is run, propagating exceptions. @@ -812,6 +899,9 @@ shakeEnqueue ShakeExtras{actionQueue, shakeRecorder} act = do return (wait' b >>= either throwIO return) data VFSModified = VFSUnmodified | VFSModified !VFS +instance Semigroup VFSModified where + VFSUnmodified <> x = x + x <> _ = x -- | Set up a new 'ShakeSession' with a set of initial actions -- Will crash if there is an existing 'ShakeSession' running. From f76bff43821d6c52623319ed14766a98b5b1412a Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 8 May 2024 05:18:02 +0800 Subject: [PATCH 36/51] handle error during stopShakeSession --- ghcide/src/Development/IDE/Core/Shake.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4a5c137125..edefc0f4af 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -826,7 +826,7 @@ runWithShake f = do -- prepare the restart stopShakeSession :: RestartArguments -> IO Seconds stopShakeSession RestartArguments{restartIdeState=IdeState{..}, ..} = do - withMVar shakeSession + withMVarMasked shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner keys <- restartActionBetweenShakeSession From ebfb3751afa2d65291fe7757d61414d12dade872 Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 8 May 2024 06:49:15 +0800 Subject: [PATCH 37/51] more sync --- ghcide/src/Development/IDE/Core/Shake.hs | 73 +++++++++++------------- ghcide/test/exe/DiagnosticTests.hs | 7 ++- 2 files changed, 39 insertions(+), 41 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index edefc0f4af..6dd5aa52ab 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -78,9 +78,11 @@ module Development.IDE.Core.Shake( ) where import Control.Concurrent.Async -import Control.Concurrent.Extra (signalBarrier) +import Control.Concurrent.Extra (signalBarrier, + waitBarrier) import Control.Concurrent.STM -import Control.Concurrent.STM (writeTQueue) +import Control.Concurrent.STM (readTQueue, + writeTQueue) import Control.Concurrent.STM.Stats (atomicallyNamed) import Control.Concurrent.Strict import Control.DeepSeq @@ -107,6 +109,7 @@ import Data.Hashable import qualified Data.HashMap.Strict as HMap import Data.HashSet (HashSet) import qualified Data.HashSet as HSet +import Data.List (concat) import Data.List.Extra (foldl', intercalate, partition, takeEnd) import qualified Data.List.NonEmpty as NE @@ -200,7 +203,7 @@ data Log | LogCancelledAction !T.Text | LogSessionInitialised | LogLookupPersistentKey !T.Text - | LogRestartDebounceCount !Int + | LogRestartDebounceCount !Int !String | LogShakeGarbageCollection !T.Text !Int !Seconds -- * OfInterest Log messages | LogSetFilesOfInterest ![(NormalizedFilePath, FileOfInterestStatus)] @@ -247,8 +250,8 @@ instance Pretty Log where LogSetFilesOfInterest ofInterest -> "Set files of interst to" <> Pretty.line <> indent 4 (pretty $ fmap (first fromNormalizedFilePath) ofInterest) - LogRestartDebounceCount count -> - "Restart debounce count:" <+> pretty count + LogRestartDebounceCount count reason -> + "Restart debounce count:" <+> pretty count <+> ":" <+> pretty reason -- | We need to serialize writes to the database, so we send any function that -- needs to write to the database over the channel, where it will be picked up by @@ -767,7 +770,7 @@ data RestartArguments = RestartArguments { restartVFS :: VFSModified , restartReasons :: [String] , restartActions :: [DelayedAction ()] - , restartActionBetweenShakeSession :: IO [Key] + , restartActionBetweenShakeSession :: [IO [Key]] -- barrier to wait for the session stopped , restartBarriers :: [Barrier ()] , restartRecorder :: Recorder (WithPriority Log) @@ -775,8 +778,8 @@ data RestartArguments = RestartArguments } instance Semigroup RestartArguments where - RestartArguments a1 a2 a3 a4 a5 a6 a7 <> RestartArguments b1 b2 b3 b4 b5 b6 _b7 = - RestartArguments (a1 <> b1) (a2 <> b2) (a3 <> b3) (a4 <> b4) (a5 <> b5) (a6 <> b6) a7 + RestartArguments a1 a2 a3 a4 a5 a6 _a7 <> RestartArguments b1 b2 b3 b4 b5 b6 b7 = + RestartArguments (a1 <> b1) (a2 <> b2) (a3 <> b3) (a4 <> b4) (a5 <> b5) b6 b7 -- do x until time up and do y -- doUntil time out @@ -789,38 +792,23 @@ doUntil x = do runWithShake :: (ShakeOpQueue-> IO ()) -> IO () runWithShake f = do stopQueue <- newTQueueIO - doQueue <- newTQueueIO - withAsync (stopShakeLoop stopQueue doQueue) $ - const $ withAsync (runShakeLoop doQueue) $ + -- withAsync (stopShakeLoop stopQueue doQueue) $ const $ + withAsync (runShakeLoop stopQueue) $ const $ f stopQueue where - -- keep running the stopShakeOp and stop the shake session - -- and send the restart arguments to the runShakeLoop - stopShakeLoop :: ShakeOpQueue -> ShakeOpQueue -> IO () - stopShakeLoop stopq doq = do - arg <- atomically $ readTQueue stopq - -- todo print this out - _stopTime <- stopShakeSession arg - traceM $ "Stopped shake session" - atomically $ writeTQueue doq arg - stopShakeLoop stopq doq runShakeLoop :: ShakeOpQueue -> IO () runShakeLoop q = do + argHead <- atomically $ readTQueue q sleep 0.1 - x <- atomically (tryPeekTQueue q) - when (isJust x) $ do - sleep 0.1 - args <- atomically $ flushTQueue q - traceM $ "Restarting shake with " ++ show (length args) ++ " arguments" - case NE.nonEmpty args of - Nothing -> return () - Just x -> do - let count = length x - let arg = sconcat x - let recorder = restartRecorder arg - logWith recorder Info $ LogRestartDebounceCount count - -- traceM $ "Restarting shake with " ++ show count ++ " arguments" - doShakeRestart arg 1 + args <- atomically $ flushTQueue q + case NE.nonEmpty (argHead:args) of + Nothing -> return () + Just xs -> do + let count = length xs + let arg = sconcat xs + let recorder = restartRecorder arg + logWith recorder Info $ LogRestartDebounceCount count (intercalate ", " (restartReasons arg)) + doShakeRestart arg 0 runShakeLoop q -- prepare the restart @@ -829,10 +817,7 @@ stopShakeSession RestartArguments{restartIdeState=IdeState{..}, ..} = do withMVarMasked shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - keys <- restartActionBetweenShakeSession - atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys -- signal the caller that we are done stopping and ready to restart - mapM_ (flip signalBarrier ()) restartBarriers return stopTime ) where @@ -846,6 +831,10 @@ doShakeRestart :: RestartArguments -> Seconds -> IO () doShakeRestart RestartArguments{restartIdeState=IdeState{..}, ..} stopTime = do withMVar' shakeSession (\runner -> do + (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner + keys <- concat <$> sequence restartActionBetweenShakeSession + mapM_ (flip signalBarrier ()) restartBarriers + atomically $ modifyTVar' (dirtyKeys shakeExtras) $ \x -> foldl' (flip insertKeySet) x keys res <- shakeDatabaseProfile shakeDb backlog <- readTVarIO $ dirtyKeys shakeExtras queue <- atomicallyNamed "actionQueue - peek" $ peekInProgress $ actionQueue shakeExtras @@ -857,6 +846,11 @@ doShakeRestart RestartArguments{restartIdeState=IdeState{..}, ..} stopTime = do -- See https://github.com/haskell/ghcide/issues/79 (\() -> do (,()) <$> newSession restartRecorder shakeExtras restartVFS shakeDb restartActions (intercalate ", " restartReasons)) + where + logErrorAfter :: Seconds -> IO () -> IO () + logErrorAfter seconds action = flip withAsync (const action) $ do + sleep seconds + logWith restartRecorder Error (LogBuildSessionRestartTakingTooLong seconds) -- | Restart the current 'ShakeSession' with the given system actions. @@ -869,12 +863,13 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession = { restartVFS = vfs , restartReasons = [reason] , restartActions = acts - , restartActionBetweenShakeSession = ioActionBetweenShakeSession + , restartActionBetweenShakeSession = [ioActionBetweenShakeSession] , restartBarriers = [barrier] , restartRecorder = recorder , restartIdeState = IdeState{..} } atomically $ writeTQueue (shakeOpQueue $ shakeExtras) restartArgs + waitBarrier barrier -- | Enqueue an action in the existing 'ShakeSession'. -- Returns a computation to block until the action is run, propagating exceptions. diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index fe123c5c1d..47c3a9b2fb 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -16,7 +16,8 @@ import Development.IDE.Test (diagnostic, expectDiagnostics, expectDiagnosticsWithTags, expectNoMoreDiagnostics, - flushMessages, waitForAction) + flushMessages, waitForAction, + waitForTypecheck) import Development.IDE.Types.Location import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -108,7 +109,8 @@ tests = testGroup "diagnostics" , "foo :: Int -> String" , "foo a = _ a" ] - _ <- createDoc "Testing.hs" "haskell" content + s <- createDoc "Testing.hs" "haskell" content + -- waitForTypecheck s expectDiagnostics [ ( "Testing.hs" , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String")] @@ -132,6 +134,7 @@ tests = testGroup "diagnostics" deferralTest title binding msg = testSessionWait title $ do _ <- createDoc "A.hs" "haskell" $ sourceA binding _ <- createDoc "B.hs" "haskell" sourceB + liftIO $ sleep 1 expectDiagnostics $ expectedDs msg in [ deferralTest "type error" "True" "Couldn't match expected type" From 5d77f61bb75c417308b50d4be7077447f0fbae6a Mon Sep 17 00:00:00 2001 From: Patrick Date: Wed, 8 May 2024 07:28:43 +0800 Subject: [PATCH 38/51] no debounce --- ghcide/src/Development/IDE/Core/Shake.hs | 6 +++--- ghcide/test/exe/DiagnosticTests.hs | 8 +++++++- 2 files changed, 10 insertions(+), 4 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 6dd5aa52ab..c79ce5d42a 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -799,9 +799,9 @@ runWithShake f = do runShakeLoop :: ShakeOpQueue -> IO () runShakeLoop q = do argHead <- atomically $ readTQueue q - sleep 0.1 - args <- atomically $ flushTQueue q - case NE.nonEmpty (argHead:args) of + -- sleep 0.1 + -- args <- atomically $ flushTQueue q + case NE.nonEmpty (argHead:[]) of Nothing -> return () Just xs -> do let count = length xs diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 47c3a9b2fb..204904475e 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -17,6 +17,7 @@ import Development.IDE.Test (diagnostic, expectDiagnosticsWithTags, expectNoMoreDiagnostics, flushMessages, waitForAction, + waitForBuildQueue, waitForTypecheck) import Development.IDE.Types.Location import qualified Language.LSP.Protocol.Lens as L @@ -35,6 +36,8 @@ import Control.Lens ((^.)) import Control.Monad.Extra (whenJust) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import System.Time.Extra +import Test.Hls (waitForKickDone, + waitForKickStart) import Test.Tasty import Test.Tasty.HUnit import TestUtils @@ -268,6 +271,9 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot + -- waitForKickStart + -- waitForKickDone + liftIO $ sleep 1 expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] , testSessionWait "correct reference used with hs-boot" $ do let contentB = T.unlines @@ -482,7 +488,7 @@ tests = testGroup "diagnostics" adoc <- createDoc aPath "haskell" aSource changeDoc adoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] - + waitForBuildQueue expectDiagnostics [ ( "P.hs", [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), From 36651b4983043d41c679aa8259c47fdc574536ca Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 06:23:51 +0800 Subject: [PATCH 39/51] revert --- ghcide/session-loader/Development/IDE/Session.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/ghcide/session-loader/Development/IDE/Session.hs b/ghcide/session-loader/Development/IDE/Session.hs index 629893652f..a0a5e9596e 100644 --- a/ghcide/session-loader/Development/IDE/Session.hs +++ b/ghcide/session-loader/Development/IDE/Session.hs @@ -615,9 +615,10 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do void $ modifyVar' filesMap $ flip HM.union (HM.fromList (map ((,hieYaml) . fst) $ concatMap toFlagsMap all_targets)) -- The VFS doesn't change on cradle edits, re-use the old one. -- Invalidate all the existing GhcSession build nodes by restarting the Shake session - invalidateShakeCache - -- The VFS doesn't change on cradle edits, re-use the old one. - restartShakeSession VFSUnmodified "new component" [] + keys2 <- invalidateShakeCache + restartShakeSession VFSUnmodified "new component" [] $ do + keys1 <- extendKnownTargets all_targets + return [keys1, keys2] -- Typecheck all files in the project on startup checkProject <- getCheckProject From 1d73ef5c65a5f79eaa498c1d0b7bc245d16d62e0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 06:24:33 +0800 Subject: [PATCH 40/51] revert --- ghcide/test/exe/DiagnosticTests.hs | 15 +++------------ 1 file changed, 3 insertions(+), 12 deletions(-) diff --git a/ghcide/test/exe/DiagnosticTests.hs b/ghcide/test/exe/DiagnosticTests.hs index 204904475e..fe123c5c1d 100644 --- a/ghcide/test/exe/DiagnosticTests.hs +++ b/ghcide/test/exe/DiagnosticTests.hs @@ -16,9 +16,7 @@ import Development.IDE.Test (diagnostic, expectDiagnostics, expectDiagnosticsWithTags, expectNoMoreDiagnostics, - flushMessages, waitForAction, - waitForBuildQueue, - waitForTypecheck) + flushMessages, waitForAction) import Development.IDE.Types.Location import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message @@ -36,8 +34,6 @@ import Control.Lens ((^.)) import Control.Monad.Extra (whenJust) import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) import System.Time.Extra -import Test.Hls (waitForKickDone, - waitForKickStart) import Test.Tasty import Test.Tasty.HUnit import TestUtils @@ -112,8 +108,7 @@ tests = testGroup "diagnostics" , "foo :: Int -> String" , "foo a = _ a" ] - s <- createDoc "Testing.hs" "haskell" content - -- waitForTypecheck s + _ <- createDoc "Testing.hs" "haskell" content expectDiagnostics [ ( "Testing.hs" , [(DiagnosticSeverity_Error, (2, 8), "Found hole: _ :: Int -> String")] @@ -137,7 +132,6 @@ tests = testGroup "diagnostics" deferralTest title binding msg = testSessionWait title $ do _ <- createDoc "A.hs" "haskell" $ sourceA binding _ <- createDoc "B.hs" "haskell" sourceB - liftIO $ sleep 1 expectDiagnostics $ expectedDs msg in [ deferralTest "type error" "True" "Couldn't match expected type" @@ -271,9 +265,6 @@ tests = testGroup "diagnostics" _ <- createDoc "ModuleA.hs-boot" "haskell" contentAboot _ <- createDoc "ModuleB.hs" "haskell" contentB _ <- createDoc "ModuleB.hs-boot" "haskell" contentBboot - -- waitForKickStart - -- waitForKickDone - liftIO $ sleep 1 expectDiagnostics [("ModuleB.hs", [(DiagnosticSeverity_Warning, (3,0), "Top-level binding")])] , testSessionWait "correct reference used with hs-boot" $ do let contentB = T.unlines @@ -488,7 +479,7 @@ tests = testGroup "diagnostics" adoc <- createDoc aPath "haskell" aSource changeDoc adoc [TextDocumentContentChangeEvent . InR . TextDocumentContentChangeWholeDocument $ T.unlines ["module A where", "import B", "x :: Bool", "x = y"]] - waitForBuildQueue + expectDiagnostics [ ( "P.hs", [ (DiagnosticSeverity_Error, (4, 6), "Couldn't match expected type 'Int' with actual type 'Bool'"), From bf8bb34fcbe92a760e388824afcefbe02928a116 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 06:25:32 +0800 Subject: [PATCH 41/51] revert --- ghcide/src/Development/IDE/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 5126f4b0be..7c3ffc62d6 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -370,7 +370,7 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re setSomethingModified Shake.VFSUnmodified ide "config change" $ do logWith recorder Debug $ LogConfigurationChange msg modifyClientSettings ide (const $ Just cfgObj) - return [toKey Rules.GetClientSettings emptyFilePath] + return [toNoFileKey Rules.GetClientSettings] runLanguageServer (cmapWithPrio LogLanguageServer recorder) options inH outH argsDefaultHlsConfig argsParseConfig onConfigChange setup dumpSTMStats From 06b975abd77b167a702003a70ec886f452b7049e Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 06:25:59 +0800 Subject: [PATCH 42/51] revert --- ghcide/src/Development/IDE/Main.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index 7c3ffc62d6..adae7e499e 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -90,7 +90,8 @@ import Development.IDE.Types.Options (IdeGhcSession, defaultIdeOptions, optModifyDynFlags, optTesting) -import Development.IDE.Types.Shake (WithHieDb, toKey) +import Development.IDE.Types.Shake (WithHieDb, toKey, + toNoFileKey) import GHC.Conc (atomically, getNumProcessors) import GHC.IO.Encoding (setLocaleEncoding) From 79a63e44bcf2592e635138651a88a820ecdeb968 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 06:26:31 +0800 Subject: [PATCH 43/51] revert --- ghcide/src/Development/IDE/Main.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/ghcide/src/Development/IDE/Main.hs b/ghcide/src/Development/IDE/Main.hs index adae7e499e..6e5de5612e 100644 --- a/ghcide/src/Development/IDE/Main.hs +++ b/ghcide/src/Development/IDE/Main.hs @@ -342,7 +342,6 @@ defaultMain recorder Arguments{..} = withHeapStats (cmapWithPrio LogHeapStats re } caps = LSP.resClientCapabilities env monitoring <- argsMonitoring - ide <- initialise (cmapWithPrio LogService recorder) argsDefaultHlsConfig From f387ccd4c252452fb819274357a355b87703002c Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 06:54:17 +0800 Subject: [PATCH 44/51] rename --- hls-graph/hls-graph.cabal | 4 ++-- hls-graph/src/Development/IDE/Graph/Internal/Paths.hs | 2 +- hls-graph/src/{Paths.hs => PathsHlsGraph.hs} | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) rename hls-graph/src/{Paths.hs => PathsHlsGraph.hs} (85%) diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 5ac6691898..4d92da4b30 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -65,9 +65,9 @@ library Development.IDE.Graph.KeyMap Development.IDE.Graph.KeySet Development.IDE.Graph.Rule - Paths_hls_graph + PathsHlsGraph - autogen-modules: Paths_hls_graph + autogen-modules: PathsHlsGraph hs-source-dirs: src build-depends: , aeson diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Paths.hs b/hls-graph/src/Development/IDE/Graph/Internal/Paths.hs index bccc11198f..8a71aaf362 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Paths.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Paths.hs @@ -6,7 +6,7 @@ module Development.IDE.Graph.Internal.Paths (readDataFileHTML) where #ifndef FILE_EMBED import Control.Exception (SomeException (SomeException), catch) import Control.Monad (filterM) -import Paths_hls_graph +import PathsHlsGraph import System.Directory (doesFileExist, getCurrentDirectory) import System.Environment (getExecutablePath) import System.FilePath (takeDirectory, ()) diff --git a/hls-graph/src/Paths.hs b/hls-graph/src/PathsHlsGraph.hs similarity index 85% rename from hls-graph/src/Paths.hs rename to hls-graph/src/PathsHlsGraph.hs index 291acafad8..1d6b4e976a 100644 --- a/hls-graph/src/Paths.hs +++ b/hls-graph/src/PathsHlsGraph.hs @@ -1,6 +1,6 @@ -- | Fake cabal module for local building -module Paths_hls_graph(getDataDir, version) where +module PathsHlsGraph(getDataDir, version) where import Data.Version.Extra From e51de46ac0fa77f3d81825dba1cbcd8489be735f Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 13:47:58 +0800 Subject: [PATCH 45/51] wait for shake to be back --- ghcide/src/Development/IDE/Core/Shake.hs | 10 +++++----- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 2 +- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 4befc9aef6..c72e559885 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -736,13 +736,13 @@ shakeSessionInit recorder ide@IdeState{..} = do shakeShut :: IdeState -> IO () shakeShut IdeState{..} = do - runner <- tryReadMVar shakeSession -- Shake gets unhappy if you try to close when there is a running -- request so we first abort that. - for_ runner cancelShakeSession - void $ shakeDatabaseProfile shakeDb - progressStop $ progress shakeExtras - stopMonitoring + withMVar shakeSession $ \ShakeSession{cancelShakeSession} -> do + cancelShakeSession + void $ shakeDatabaseProfile shakeDb + progressStop $ progress shakeExtras + stopMonitoring -- | This is a variant of withMVar where the first argument is run unmasked and if it throws diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 60145ff253..98b3f1d70c 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -135,7 +135,7 @@ setupLSP :: -> IO (LSP.LanguageContextEnv config -> TRequestMessage Method_Initialize -> IO (Either err (LSP.LanguageContextEnv config, IdeState)), LSP.Handlers (ServerM config), (LanguageContextEnv config, IdeState) -> ServerM config <~> IO) -setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do +setupLSP recorder getHieDbLoc userHandlers getIdeState clientMsgVar = do -- Send everything over a channel, since you need to wait until after initialise before -- LspFuncs is available clientMsgChan :: Chan ReactorMessage <- newChan From 3313246153b65f130305542345ba47beaa402eae Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 14:05:53 +0800 Subject: [PATCH 46/51] clean --- ghcide/src/Development/IDE/Core/Shake.hs | 21 +++------------------ 1 file changed, 3 insertions(+), 18 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index c72e559885..1d8143b6bb 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -809,27 +809,12 @@ runWithShake f = do let arg = sconcat xs let recorder = restartRecorder arg logWith recorder Info $ LogRestartDebounceCount count (intercalate ", " (restartReasons arg)) - doShakeRestart arg 0 + doShakeRestart arg runShakeLoop q --- prepare the restart -stopShakeSession :: RestartArguments -> IO Seconds -stopShakeSession RestartArguments{restartIdeState=IdeState{..}, ..} = do - withMVarMasked shakeSession - (\runner -> do - (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner - -- signal the caller that we are done stopping and ready to restart - return stopTime - ) - where - logErrorAfter :: Seconds -> IO () -> IO () - logErrorAfter seconds action = flip withAsync (const action) $ do - sleep seconds - logWith restartRecorder Error (LogBuildSessionRestartTakingTooLong seconds) - -doShakeRestart :: RestartArguments -> Seconds -> IO () -doShakeRestart RestartArguments{restartIdeState=IdeState{..}, ..} stopTime = do +doShakeRestart :: RestartArguments -> IO () +doShakeRestart RestartArguments{restartIdeState=IdeState{..}, ..} = do withMVar' shakeSession (\runner -> do (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner From e758db6078ce57a2e1acd26193414f17af3c50a7 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 14:06:29 +0800 Subject: [PATCH 47/51] clean --- ghcide/src/Development/IDE/Core/Shake.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs index 1d8143b6bb..3b08ab5e6b 100644 --- a/ghcide/src/Development/IDE/Core/Shake.hs +++ b/ghcide/src/Development/IDE/Core/Shake.hs @@ -782,14 +782,6 @@ instance Semigroup RestartArguments where RestartArguments a1 a2 a3 a4 a5 a6 _a7 <> RestartArguments b1 b2 b3 b4 b5 b6 b7 = RestartArguments (a1 <> b1) (a2 <> b2) (a3 <> b3) (a4 <> b4) (a5 <> b5) b6 b7 --- do x until time up and do y --- doUntil time out -doUntil :: IO a -> IO [a] -doUntil x = do - res <- x - rest <- doUntil x - return (res:rest) - runWithShake :: (ShakeOpQueue-> IO ()) -> IO () runWithShake f = do stopQueue <- newTQueueIO From 17cc8698b542c093fec04411c19c23fdaeddf7dc Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 14:43:48 +0800 Subject: [PATCH 48/51] log shutdown --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 98b3f1d70c..c30981d8c5 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -32,6 +32,7 @@ import UnliftIO.Directory import UnliftIO.Exception import qualified Colog.Core as Colog +import Control.Concurrent.Extra (newBarrier) import Control.Monad.IO.Unlift (MonadUnliftIO) import Development.IDE.Core.IdeConfiguration import Development.IDE.Core.Service (ShakeOpQueue, @@ -53,6 +54,7 @@ data Log | LogSession Session.Log | LogLspServer LspServerLog | LogServerShutdownMessage + | LogServerShutdownDoneMessage deriving Show instance Pretty Log where @@ -77,6 +79,7 @@ instance Pretty Log where LogSession msg -> pretty msg LogLspServer msg -> pretty msg LogServerShutdownMessage -> "Received shutdown message" + LogServerShutdownDoneMessage -> "Server shutdown done" -- used to smuggle RankNType WithHieDb through dbMVar newtype WithHieDbShield = WithHieDbShield WithHieDb @@ -268,6 +271,7 @@ shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide + liftIO $ logWith recorder Debug LogServerShutdownMessage resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) From 0a95e76b34e39745cf9ca5ae728e0a71a9cef9e0 Mon Sep 17 00:00:00 2001 From: Patrick Date: Sat, 11 May 2024 16:08:38 +0800 Subject: [PATCH 49/51] add shutdown over log --- ghcide/src/Development/IDE/LSP/LanguageServer.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index c30981d8c5..fa8d5f5195 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -242,6 +242,7 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa case msg of ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k + -- todo cancel shake session and log here logWith recorder Info LogReactorThreadStopped (WithHieDbShield withHieDb,hieChan,sq) <- takeMVar dbMVar @@ -271,7 +272,7 @@ shutdownHandler recorder stopReactor = LSP.requestHandler SMethod_Shutdown $ \_ liftIO stopReactor -- flush out the Shake session to record a Shake profile if applicable liftIO $ shakeShut ide - liftIO $ logWith recorder Debug LogServerShutdownMessage + liftIO $ logWith recorder Debug LogServerShutdownDoneMessage resp $ Right Null exitHandler :: IO () -> LSP.Handlers (ServerM c) From 17591b00ba692eb7c93301b3974803456c8ac97f Mon Sep 17 00:00:00 2001 From: Patrick Date: Sun, 12 May 2024 07:45:05 +0800 Subject: [PATCH 50/51] revert file name changed --- hls-graph/hls-graph.cabal | 4 ++-- hls-graph/src/Development/IDE/Graph/Internal/Paths.hs | 2 +- hls-graph/src/PathsHlsGraph.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 4d92da4b30..5ac6691898 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -65,9 +65,9 @@ library Development.IDE.Graph.KeyMap Development.IDE.Graph.KeySet Development.IDE.Graph.Rule - PathsHlsGraph + Paths_hls_graph - autogen-modules: PathsHlsGraph + autogen-modules: Paths_hls_graph hs-source-dirs: src build-depends: , aeson diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Paths.hs b/hls-graph/src/Development/IDE/Graph/Internal/Paths.hs index 8a71aaf362..bccc11198f 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Paths.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Paths.hs @@ -6,7 +6,7 @@ module Development.IDE.Graph.Internal.Paths (readDataFileHTML) where #ifndef FILE_EMBED import Control.Exception (SomeException (SomeException), catch) import Control.Monad (filterM) -import PathsHlsGraph +import Paths_hls_graph import System.Directory (doesFileExist, getCurrentDirectory) import System.Environment (getExecutablePath) import System.FilePath (takeDirectory, ()) diff --git a/hls-graph/src/PathsHlsGraph.hs b/hls-graph/src/PathsHlsGraph.hs index 1d6b4e976a..291acafad8 100644 --- a/hls-graph/src/PathsHlsGraph.hs +++ b/hls-graph/src/PathsHlsGraph.hs @@ -1,6 +1,6 @@ -- | Fake cabal module for local building -module PathsHlsGraph(getDataDir, version) where +module Paths_hls_graph(getDataDir, version) where import Data.Version.Extra From bca25ae0960c5867e1bf4c6255f6a6ced854ba33 Mon Sep 17 00:00:00 2001 From: Patrick Date: Mon, 13 May 2024 10:32:27 +0800 Subject: [PATCH 51/51] format --- ghcide/src/Development/IDE/Core/Service.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/Service.hs b/ghcide/src/Development/IDE/Core/Service.hs index 1d7fdc0499..b66116627e 100644 --- a/ghcide/src/Development/IDE/Core/Service.hs +++ b/ghcide/src/Development/IDE/Core/Service.hs @@ -117,5 +117,3 @@ shutdown st = shakeShut st runAction :: String -> IdeState -> Action a -> IO a runAction herald ide act = join $ shakeEnqueue (shakeExtras ide) (mkDelayedAction herald Logger.Debug act) - -