update hls-graph runtime

Author: soulomoon

ghcide/ghcide.cabal

@@ -142,7 +142,6 @@ library
     Development.IDE.Core.Shake
     Development.IDE.Core.Tracing
     Development.IDE.Core.UseStale
-    Development.IDE.Core.WorkerThread
     Development.IDE.GHC.Compat
     Development.IDE.GHC.Compat.Core
     Development.IDE.GHC.Compat.CmdLine

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

@@ -81,15 +81,13 @@ import           Data.Void
 
 import           Control.Concurrent.STM.Stats        (atomically, modifyTVar',
                                                       readTVar, writeTVar)
-import           Control.Concurrent.STM.TQueue
 import           Control.Monad.Trans.Cont            (ContT (ContT, runContT))
 import           Data.Foldable                       (for_)
 import           Data.HashMap.Strict                 (HashMap)
 import           Data.HashSet                        (HashSet)
 import qualified Data.HashSet                        as Set
 import           Database.SQLite.Simple
 import           Development.IDE.Core.Tracing        (withTrace)
-import           Development.IDE.Core.WorkerThread   (withWorkerQueue)
 import           Development.IDE.Session.Dependency
 import           Development.IDE.Session.Diagnostics (renderCradleError)
 import           Development.IDE.Session.Ghc         hiding (Log)
@@ -108,6 +106,7 @@ import qualified Control.Monad.STM                   as STM
 import           Control.Monad.Trans.Reader
 import qualified Development.IDE.Session.Ghc         as Ghc
 import qualified Development.IDE.Session.OrderedSet  as S
+import           Development.IDE.WorkerThread
 import qualified Focus
 import qualified StmContainers.Map                   as STM
 
@@ -133,10 +132,13 @@ data Log
   | LogLookupSessionCache !FilePath
   | LogTime !String
   | LogSessionGhc Ghc.Log
+  | LogSessionWorkerThread LogWorkerThread
 deriving instance Show Log
 
+
 instance Pretty Log where
   pretty = \case
+    LogSessionWorkerThread lt -> pretty lt
     LogTime s -> "Time:" <+> pretty s
     LogLookupSessionCache path -> "Looking up session cache for" <+> pretty path
     LogGetOptionsLoop fp -> "Loop: getOptions for" <+> pretty fp
@@ -362,7 +364,7 @@ runWithDb recorder fp = ContT $ \k -> do
     _ <- withWriteDbRetryable deleteMissingRealFiles
     _ <- withWriteDbRetryable garbageCollectTypeNames
 
-    runContT (withWorkerQueue (writer withWriteDbRetryable)) $ \chan ->
+    runContT (withWorkerQueue (logWith (cmapWithPrio LogSessionWorkerThread recorder) Debug) "hiedb thread"  (writer withWriteDbRetryable)) $ \chan ->
         withHieDb fp (\readDb -> k (WithHieDbShield $ makeWithHieDbRetryable recorder rng readDb, chan))
   where
     writer withHieDbRetryable l = do
@@ -589,7 +591,7 @@ newSessionState = do
 -- components mapping to the same hie.yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
 
-loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TQueue (IO ()) -> IO (Action IdeGhcSession)
+loadSessionWithOptions :: Recorder (WithPriority Log) -> SessionLoadingOptions -> FilePath -> TaskQueue (IO ()) -> IO (Action IdeGhcSession)
 loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
   let toAbsolutePath = toAbsolute rootDir -- see Note [Root Directory]
 
@@ -617,7 +619,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
 
     -- see Note [Serializing runs in separate thread]
     -- Start the getOptionsLoop if the queue is empty
-    liftIO $ atomically $ Extra.whenM (isEmptyTQueue que) $ do
+    liftIO $ atomically $ Extra.whenM (isEmptyTaskQueue que) $ do
       let newSessionLoadingOptions = SessionLoadingOptions
             { findCradle = cradleLoc
             , ..
@@ -636,7 +638,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} rootDir que = do
             , sessionLoadingOptions = newSessionLoadingOptions
             }
 
-      writeTQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv)
+      writeTaskQueue que (runReaderT (getOptionsLoop recorder sessionShake sessionState knownTargetsVar) sessionEnv)
 
     -- Each one of deps will be registered as a FileSystemWatcher in the GhcSession action
     -- so that we can get a workspace/didChangeWatchedFiles notification when a dep changes.
@@ -935,7 +937,7 @@ loadCradleWithNotifications recorder sessionState loadCradle hieYaml cfp = do
   when (isNothing hieYaml) $
     logWith recorder Warning $ LogCradleNotFound lfpLog
   cradle <- liftIO $ loadCradle hieYaml rootDir
-  when (isTesting) $ mRunLspT lspEnv $
+  when isTesting $ mRunLspT lspEnv $
     sendNotification (SMethod_CustomMethod (Proxy @"ghcide/cradle/loaded")) (toJSON cfp)
 
   -- Display a user friendly progress message here: They probably don't know what a cradle is
@@ -1034,7 +1036,7 @@ data PackageSetupException
         { compileTime :: !Version
         , runTime     :: !Version
         }
-    deriving (Eq, Show, Typeable)
+    deriving (Eq, Show)
 
 instance Exception PackageSetupException
 

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

@@ -114,7 +114,6 @@ import qualified GHC.Runtime.Loader                           as Loader
 import           GHC.Tc.Gen.Splice
 import           GHC.Types.Error
 import           GHC.Types.ForeignStubs
-import           GHC.Types.HpcInfo
 import           GHC.Types.TypeEnv
 
 -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
@@ -151,6 +150,7 @@ import           GHC.Iface.Ext.Types                          (NameEntityInfo)
 
 #if MIN_VERSION_ghc(9,12,0)
 import           Development.IDE.Import.FindImports
+import Development.IDE.WorkerThread (writeTaskQueue)
 #endif
 
 --Simple constants to make sure the source is consistently named
@@ -883,7 +883,7 @@ indexHieFile se mod_summary srcPath !hash hf = do
       -- hiedb doesn't use the Haskell src, so we clear it to avoid unnecessarily keeping it around
       let !hf' = hf{hie_hs_src = mempty}
       modifyTVar' indexPending $ HashMap.insert srcPath hash
-      writeTQueue indexQueue $ \withHieDb -> do
+      writeTaskQueue indexQueue $ \withHieDb -> do
         -- We are now in the worker thread
         -- Check if a newer index of this file has been scheduled, and if so skip this one
         newerScheduled <- atomically $ do

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

@@ -25,7 +25,6 @@ module Development.IDE.Core.FileStore(
     ) where
 
 import           Control.Concurrent.STM.Stats                 (STM, atomically)
-import           Control.Concurrent.STM.TQueue                (writeTQueue)
 import           Control.Exception
 import           Control.Lens                                 ((^.))
 import           Control.Monad.Extra
@@ -52,6 +51,7 @@ import           Development.IDE.Types.Diagnostics
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import           Development.IDE.Types.Shake                  (toKey)
+import           Development.IDE.WorkerThread                 (writeTaskQueue)
 import           HieDb.Create                                 (deleteMissingRealFiles)
 import           Ide.Logger                                   (Pretty (pretty),
                                                                Priority (Info),
@@ -82,7 +82,6 @@ data Log
   = LogCouldNotIdentifyReverseDeps !NormalizedFilePath
   | LogTypeCheckingReverseDeps !NormalizedFilePath !(Maybe [NormalizedFilePath])
   | LogShake Shake.Log
-  | LogGetModificationTime !NormalizedFilePath
   deriving Show
 
 instance Pretty Log where
@@ -95,8 +94,6 @@ instance Pretty Log where
       <> ":"
       <+> pretty (fmap (fmap show) reverseDepPaths)
     LogShake msg -> pretty msg
-    LogGetModificationTime path ->
-      "Getting modification time for" <+> viaShow path
 
 addWatchedFileRule :: Recorder (WithPriority Log) -> (NormalizedFilePath -> Action Bool) -> Rules ()
 addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogShake recorder) $ \AddWatchedFile f -> do
@@ -113,7 +110,6 @@ addWatchedFileRule recorder isWatched = defineNoDiagnostics (cmapWithPrio LogSha
 
 getModificationTimeRule :: Recorder (WithPriority Log) -> Rules ()
 getModificationTimeRule recorder = defineEarlyCutoff (cmapWithPrio LogShake recorder) $ Rule $ \(GetModificationTime_ missingFileDiags) file -> do
-    logWith recorder Info $ LogGetModificationTime file
     getModificationTimeImpl missingFileDiags file
 
 getModificationTimeImpl
@@ -306,7 +302,7 @@ 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
-    atomically $ writeTQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
+    atomically $ writeTaskQueue (indexQueue $ hiedbWriter $ shakeExtras state) (\withHieDb -> withHieDb deleteMissingRealFiles)
     void $ restartShakeSession (shakeExtras state) vfs reason [] actionBetweenSession
 
 registerFileWatches :: [String] -> LSP.LspT Config IO Bool

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

@@ -57,6 +57,10 @@ instance Pretty Log where
   pretty = \case
     LogShake msg -> pretty msg
 
+newtype OfInterestVar = OfInterestVar (Var (HashMap NormalizedFilePath FileOfInterestStatus))
+
+instance IsIdeGlobal OfInterestVar
+
 -- | The rule that initialises the files of interest state.
 ofInterestRules :: Recorder (WithPriority Log) -> Rules ()
 ofInterestRules recorder = do
@@ -75,6 +79,9 @@ ofInterestRules recorder = do
     summarize (IsFOI (Modified False)) = BS.singleton 2
     summarize (IsFOI (Modified True))  = BS.singleton 3
 
+------------------------------------------------------------
+newtype GarbageCollectVar = GarbageCollectVar (Var Bool)
+instance IsIdeGlobal GarbageCollectVar
 
 ------------------------------------------------------------
 -- Exposed API
@@ -147,6 +154,10 @@ kick = do
 
     liftIO $ progressUpdate progress ProgressCompleted
 
+    GarbageCollectVar var <- getIdeGlobalAction
+    garbageCollectionScheduled <- liftIO $ readVar var
+    when garbageCollectionScheduled $ do
+        void garbageCollectDirtyKeys
+        liftIO $ writeVar var False
 
     signal (Proxy @"kick/done")
-

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

@@ -28,7 +28,6 @@ import           Control.Lens                ((^.))
 import           Control.Monad
 import           Data.Algorithm.Diff
 import           Data.Bifunctor
-import           Data.List
 import qualified Data.Text                   as T
 import qualified Data.Vector.Unboxed         as V
 import qualified Language.LSP.Protocol.Lens  as L

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

@@ -722,7 +722,7 @@ loadGhcSession recorder ghcSessionDepsConfig = do
                 itExists <- getFileExists nfp
                 when itExists $ void $ do
                   use_ GetPhysicalModificationTime nfp
-        logWith recorder Logger.Info $ LogDependencies file deps
+        logWith recorder Logger.Debug $ LogDependencies file deps
         mapM_ addDependency deps
 
         let cutoffHash = LBS.toStrict $ B.encode (hash (snd val))