From 343913184f7775f613ae94b28b89aa60e0f70bac Mon Sep 17 00:00:00 2001
From: Patrick <fwy996602672@gmail.com>
Date: Mon, 29 Apr 2024 23:59:56 +0800
Subject: [PATCH 1/9] move dirty key set to hls

---
 ghcide/ghcide.cabal                           |  1 +
 ghcide/src/Development/IDE/Core/Shake.hs      | 83 ++++++++-----------
 ghcide/src/Development/IDE/Plugin/Test.hs     |  2 +-
 .../src/Development/IDE/Graph/Database.hs     |  5 +-
 .../IDE/Graph/Internal/Database.hs            |  8 +-
 .../Development/IDE/Graph/Internal/Types.hs   | 10 ++-
 6 files changed, 56 insertions(+), 53 deletions(-)

diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
index 57f2b28770..f021e4db6b 100644
--- a/ghcide/ghcide.cabal
+++ b/ghcide/ghcide.cabal
@@ -242,6 +242,7 @@ executable ghcide
   main-is:            Main.hs
   build-depends:
     , base                  >=4.16 && <5
+    , Cabal >= 3.12
     , data-default
     , extra
     , ghcide
diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs
index 0d1eb3ea60..ac0610ae6c 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,
@@ -136,7 +136,9 @@ import           Development.IDE.Graph.Database         (ShakeDatabase,
                                                          shakeGetDatabaseKeys,
                                                          shakeNewDatabase,
                                                          shakeProfileDatabase,
-                                                         shakeRunDatabaseForKeys)
+                                                         shakeRunDatabaseForKeys,
+                                                         shakeGetDirtySet,
+                                                         getDatabaseDirtyKeys)
 import           Development.IDE.Graph.Rule
 import           Development.IDE.Types.Action
 import           Development.IDE.Types.Diagnostics
@@ -183,7 +185,7 @@ import           Development.IDE.GHC.Compat             (mkSplitUniqSupply,
 data Log
   = LogCreateHieDbExportsMapStart
   | LogCreateHieDbExportsMapFinish !Int
-  | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath)
+  | LogBuildSessionRestart !String ![DelayedActionInternal] ![Key] !Seconds !(Maybe FilePath)
   | LogBuildSessionRestartTakingTooLong !Seconds
   | LogDelayedAction !(DelayedAction ()) !Seconds
   | LogBuildSessionFinish !(Maybe SomeException)
@@ -208,7 +210,7 @@ instance Pretty Log where
       vcat
         [ "Restarting build session due to" <+> pretty reason
         , "Action Queue:" <+> pretty (map actionName actionQueue)
-        , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog)
+        , "Keys:" <+> pretty (map show $ keyBackLog)
         , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ]
     LogBuildSessionRestartTakingTooLong seconds ->
         "Build restart is taking too long (" <> pretty seconds <> " seconds)"
@@ -274,7 +276,7 @@ data ShakeExtras = ShakeExtras
     ,globals :: TVar (HMap.HashMap TypeRep Dynamic)
       -- ^ Registry of global state used by rules.
       -- Small and immutable after startup, so not worth using an STM.Map.
-    ,state :: Values
+    ,ruleState :: Values
     ,diagnostics :: STMDiagnosticStore
     ,hiddenDiagnostics :: STMDiagnosticStore
     ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic]
@@ -327,8 +329,6 @@ data ShakeExtras = ShakeExtras
     -- We don't need a STM.Map because we never update individual keys ourselves.
     , defaultConfig :: Config
       -- ^ 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
     }
 
 type WithProgressFunc = forall a.
@@ -447,7 +447,7 @@ getIdeOptionsIO ide = do
 -- | Return the most recent, potentially stale, value and a PositionMapping
 -- for the version of that value.
 lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
-lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
+lastValueIO s@ShakeExtras{positionMapping,persistentKeys,ruleState} k file = do
 
     let readPersistent
           | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests
@@ -461,7 +461,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
           case mv of
             Nothing -> atomicallyNamed "lastValueIO 1" $ do
-                STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state
+                STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) ruleState
                 return Nothing
             Just (v,del,mbVer) -> do
                 actual_version <- case mbVer of
@@ -469,7 +469,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
                   Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file))
                               `catch` (\(_ :: IOException) -> pure Nothing)
                 atomicallyNamed "lastValueIO 2" $ do
-                  STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state
+                  STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) ruleState
                   Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping file actual_version
 
         -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics
@@ -480,7 +480,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
           -- Something already succeeded before, leave it alone
           _        -> old
 
-    atomicallyNamed "lastValueIO 4"  (STM.lookup (toKey k file) state) >>= \case
+    atomicallyNamed "lastValueIO 4"  (STM.lookup (toKey k file) ruleState) >>= \case
       Nothing -> readPersistent
       Just (ValueWithDiagnostics value _) -> case value of
         Succeeded ver (fromDynamic -> Just v) ->
@@ -564,20 +564,10 @@ deleteValue
   -> k
   -> NormalizedFilePath
   -> STM [Key]
-deleteValue ShakeExtras{dirtyKeys, state} key file = do
-    STM.delete (toKey key file) state
+deleteValue ShakeExtras{ruleState} key file = do
+    STM.delete (toKey key file) ruleState
     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.
@@ -671,7 +661,6 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
         actionQueue <- newQueue
 
         let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv
-        dirtyKeys <- newTVarIO mempty
         -- Take one VFS snapshot at the start
         vfsVar <- newTVarIO =<< vfsSnapshot lspEnv
         pure ShakeExtras{shakeRecorder = recorder, ..}
@@ -691,7 +680,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
 
     -- monitoring
     let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras
-        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras)
+        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDirtySet shakeDb
         readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)
         readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras)
         readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb
@@ -711,7 +700,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
 
 
 getStateKeys :: ShakeExtras -> IO [Key]
-getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state
+getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . ruleState
 
 -- | Must be called in the 'Initialized' handler and only once
 shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()
@@ -719,7 +708,7 @@ shakeSessionInit recorder ide@IdeState{..} = do
     -- Take a snapshot of the VFS - it should be empty as we've received no notifications
     -- till now, but it can't hurt to be in sync with the `lsp` library.
     vfs <- vfsSnapshot (lspEnv shakeExtras)
-    initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit"
+    initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" []
     putMVar shakeSession initSession
     logWith recorder Debug LogSessionInitialised
 
@@ -765,20 +754,19 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
         shakeSession
         (\runner -> do
               (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
-              keys <- ioActionBetweenShakeSession
-              join $ atomically $ recordDirtyKeys shakeExtras keys
+              dirtyKeys <- ioActionBetweenShakeSession
               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 recorder Debug $ LogBuildSessionRestart reason queue dirtyKeys stopTime res
+              return dirtyKeys
         )
         -- 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)
+        (\dirtyKeys -> do
+          (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason dirtyKeys)
     where
         logErrorAfter :: Seconds -> IO () -> IO ()
         logErrorAfter seconds action = flip withAsync (const action) $ do
@@ -818,8 +806,9 @@ newSession
     -> ShakeDatabase
     -> [DelayedActionInternal]
     -> String
+    -> [Key]
     -> IO ShakeSession
-newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
+newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason theDirtyKeys = do
 
     -- Take a new VFS snapshot
     case vfsMod of
@@ -828,10 +817,7 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
 
     IdeOptions{optRunSubset} <- getIdeOptionsIO extras
     reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue
-    allPendingKeys <-
-        if optRunSubset
-          then Just <$> readTVarIO dirtyKeys
-          else return Nothing
+    let allPendingKeys = if optRunSubset then Just theDirtyKeys else Nothing
     let
         -- A daemon-like action used to inject additional work
         -- Runs actions from the work queue sequentially
@@ -852,10 +838,10 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
         workRun restore = withSpan "Shake session" $ \otSpan -> do
           setTag otSpan "reason" (fromString reason)
           setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued)
-          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk)
+          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show kk)
           let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)
           res <- try @SomeException $
-            restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs
+            restore $ shakeRunDatabaseForKeys allPendingKeys shakeDb keysActs
           return $ do
               let exception =
                     case res of
@@ -924,9 +910,10 @@ garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection
 garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
 garbageCollectKeys label maxAge checkParents agedKeys = do
     start <- liftIO offsetTime
-    ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras
+    ShakeExtras{ruleState, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras
+    dirtyKeys <- getDatabaseDirtyKeys
     (n::Int, garbage) <- liftIO $
-        foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys
+        foldM (removeDirtyKey dirtyKeys ruleState) (0,[]) agedKeys
     t <- liftIO start
     when (n>0) $ liftIO $ do
         logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t
@@ -1060,8 +1047,8 @@ useWithStaleFast' key file = do
   -- keep updating the value in the key.
   waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file
 
-  s@ShakeExtras{state} <- askShake
-  r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file
+  s@ShakeExtras{ruleState} <- askShake
+  r <- liftIO $ atomicallyNamed "useStateFast" $ getValues ruleState key file
   liftIO $ case r of
     -- block for the result if we haven't computed before
     Nothing -> do
@@ -1188,12 +1175,12 @@ defineEarlyCutoff'
     -> (Value v -> Action (Maybe BS.ByteString, IdeResult v))
     -> Action (RunResult (A (RuleResult k)))
 defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
-    ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras
+    ShakeExtras{ruleState, progress} <- getShakeExtras
     options <- getIdeOptions
     (if optSkipProgress options key then id else inProgress progress file) $ do
         val <- case mbOld of
             Just old | mode == RunDependenciesSame -> do
-                mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file
+                mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues ruleState key file
                 case mbValue of
                     -- No changes in the dependencies and we have
                     -- an existing successful result.
@@ -1209,7 +1196,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
         res <- case val of
             Just res -> return res
             Nothing -> do
-                staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case
+                staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues ruleState key file <&> \case
                     Nothing                   -> Failed False
                     Just (Succeeded ver v, _) -> Stale Nothing ver v
                     Just (Stale d ver v, _)   -> Stale d ver v
@@ -1235,7 +1222,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
                     (encodeShakeValue bs)
                     (A res)
-                    (setValues state key file res (Vector.fromList diags) >> modifyTVar' dirtyKeys (deleteKeySet $ toKey key file))
+                    (setValues ruleState key file res (Vector.fromList diags))
         return res
   where
     -- Highly unsafe helper to compute the version of a file
diff --git a/ghcide/src/Development/IDE/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs
index 5dfc8460b0..22ab3c7482 100644
--- a/ghcide/src/Development/IDE/Plugin/Test.hs
+++ b/ghcide/src/Development/IDE/Plugin/Test.hs
@@ -131,7 +131,7 @@ testRequestHandler s (GarbageCollectDirtyKeys parents age) = do
     res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents
     return $ Right $ toJSON $ map show res
 testRequestHandler s GetStoredKeys = do
-    keys <- liftIO $ atomically $ map fst <$> ListT.toList (STM.listT $ state $ shakeExtras s)
+    keys <- liftIO $ atomically $ map fst <$> ListT.toList (STM.listT $ ruleState $ shakeExtras s)
     return $ Right $ toJSON $ map show keys
 testRequestHandler s GetFilesOfInterest = do
     ff <- liftIO $ getFilesOfInterest s
diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs
index bd8601cd16..1551b163ef 100644
--- a/hls-graph/src/Development/IDE/Graph/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Database.hs
@@ -8,8 +8,9 @@ module Development.IDE.Graph.Database(
     shakeGetBuildStep,
     shakeGetDatabaseKeys,
     shakeGetDirtySet,
-    shakeGetCleanKeys
-    ,shakeGetBuildEdges) where
+    shakeGetCleanKeys,
+    getDatabaseDirtyKeys,
+    shakeGetBuildEdges) where
 import           Control.Concurrent.STM.Stats            (readTVarIO)
 import           Data.Dynamic
 import           Data.Maybe
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
index 8d956e74c9..415fd28fee 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -47,6 +47,7 @@ newDatabase :: Dynamic -> TheRules -> IO Database
 newDatabase databaseExtra databaseRules = do
     databaseStep <- newTVarIO $ Step 0
     databaseValues <- atomically SMap.new
+    databaseDirtyKeys <- newTVarIO mempty
     pure Database{..}
 
 -- | Increment the step and mark dirty.
@@ -60,7 +61,9 @@ incDatabase db (Just kk) = do
         -- Updating all the keys atomically is not necessary
         -- since we assume that no build is mutating the db.
         -- Therefore run one transaction per key to minimise contention.
-        atomicallyNamed "incDatabase" $ SMap.focus updateDirty k (databaseValues db)
+        atomicallyNamed "incDatabase" $ do
+            modifyTVar' (databaseDirtyKeys db) (insertKeySet k)
+            SMap.focus updateDirty k (databaseValues db)
 
 -- all keys are dirty
 incDatabase db Nothing = do
@@ -120,6 +123,7 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do
                     let act = run (refresh db stack id s)
                         (force, val) = splitIO (join act)
                     SMap.focus (updateStatus $ Running current force val s) id databaseValues
+
                     modifyTVar' toForce (Spawn force:)
                     pure val
 
@@ -200,7 +204,9 @@ compute db@Database{..} stack key mode result = do
                     (getResultDepsDefault mempty previousDeps)
                     deps
         _ -> pure ()
+
     atomicallyNamed "compute and run hook" $ do
+        modifyTVar' databaseDirtyKeys (deleteKeySet key)
         runHook
         SMap.focus (updateStatus $ Clean res) key databaseValues
     pure res
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
index 3474289b42..3ba276ffb0 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
@@ -28,6 +28,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)
@@ -107,9 +108,13 @@ data Database = Database {
     databaseExtra  :: Dynamic,
     databaseRules  :: TheRules,
     databaseStep   :: !(TVar Step),
-    databaseValues :: !(Map Key KeyDetails)
+    databaseValues :: !(Map Key KeyDetails),
+    databaseDirtyKeys :: !(TVar KeySet)
     }
 
+getDatabaseDirtyKeys :: Action (TVar KeySet)
+getDatabaseDirtyKeys = Action $ asks (databaseDirtyKeys . actionDatabase)
+
 getDatabaseValues :: Database -> IO [(Key, Status)]
 getDatabaseValues = atomically
                   . (fmap.fmap) (second keyStatus)
@@ -207,6 +212,9 @@ data RunResult value = RunResult
         -- ^ The hook to run after the rule completes.
     } deriving Functor
 
+instance NFData value => NFData (RunResult value) where
+    rnf (RunResult x1 x2 x3 _) = rnf x1 `seq` x2 `seq` rnf x3
+
 ---------------------------------------------------------------------
 -- EXCEPTIONS
 

From 4a7e35ef2f9180434d685a81ba1a5c16337a48d8 Mon Sep 17 00:00:00 2001
From: Patrick <fwy996602672@gmail.com>
Date: Tue, 30 Apr 2024 00:00:20 +0800
Subject: [PATCH 2/9] kick transitiveDirtyKeys aggressively

---
 hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
index 415fd28fee..a3d2b3527e 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -57,6 +57,8 @@ incDatabase :: Database -> Maybe [Key] -> IO ()
 incDatabase db (Just kk) = do
     atomicallyNamed "incDatabase" $ modifyTVar'  (databaseStep db) $ \(Step i) -> Step $ i + 1
     transitiveDirtyKeys <- transitiveDirtySet db kk
+    -- kick off the computation for the dirty keys
+    _res <- runAIO $ builder db emptyStack (toListKeySet transitiveDirtyKeys)
     for_ (toListKeySet transitiveDirtyKeys) $ \k ->
         -- Updating all the keys atomically is not necessary
         -- since we assume that no build is mutating the db.

From c053e68ff2a44c81c7b1aa4c073647bc4668132d Mon Sep 17 00:00:00 2001
From: Patrick <fwy996602672@gmail.com>
Date: Tue, 30 Apr 2024 02:23:59 +0800
Subject: [PATCH 3/9] Revert "kick transitiveDirtyKeys aggressively"

This reverts commit 4a7e35ef2f9180434d685a81ba1a5c16337a48d8.
---
 hls-graph/src/Development/IDE/Graph/Internal/Database.hs | 2 --
 1 file changed, 2 deletions(-)

diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
index a3d2b3527e..415fd28fee 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -57,8 +57,6 @@ incDatabase :: Database -> Maybe [Key] -> IO ()
 incDatabase db (Just kk) = do
     atomicallyNamed "incDatabase" $ modifyTVar'  (databaseStep db) $ \(Step i) -> Step $ i + 1
     transitiveDirtyKeys <- transitiveDirtySet db kk
-    -- kick off the computation for the dirty keys
-    _res <- runAIO $ builder db emptyStack (toListKeySet transitiveDirtyKeys)
     for_ (toListKeySet transitiveDirtyKeys) $ \k ->
         -- Updating all the keys atomically is not necessary
         -- since we assume that no build is mutating the db.

From e63dfbaea41dee41b2443b14bcbc035764e440fb Mon Sep 17 00:00:00 2001
From: Patrick <fwy996602672@gmail.com>
Date: Tue, 30 Apr 2024 21:27:36 +0800
Subject: [PATCH 4/9] Revert "move dirty key set to hls"

This reverts commit 343913184f7775f613ae94b28b89aa60e0f70bac.
---
 ghcide/ghcide.cabal                           |  1 -
 ghcide/src/Development/IDE/Core/Shake.hs      | 83 +++++++++++--------
 ghcide/src/Development/IDE/Plugin/Test.hs     |  2 +-
 .../src/Development/IDE/Graph/Database.hs     |  5 +-
 .../IDE/Graph/Internal/Database.hs            |  8 +-
 .../Development/IDE/Graph/Internal/Types.hs   | 10 +--
 6 files changed, 53 insertions(+), 56 deletions(-)

diff --git a/ghcide/ghcide.cabal b/ghcide/ghcide.cabal
index f021e4db6b..57f2b28770 100644
--- a/ghcide/ghcide.cabal
+++ b/ghcide/ghcide.cabal
@@ -242,7 +242,6 @@ executable ghcide
   main-is:            Main.hs
   build-depends:
     , base                  >=4.16 && <5
-    , Cabal >= 3.12
     , data-default
     , extra
     , ghcide
diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs
index ac0610ae6c..0d1eb3ea60 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,
+    deleteValue, recordDirtyKeys,
     WithProgressFunc, WithIndefiniteProgressFunc,
     ProgressEvent(..),
     DelayedAction, mkDelayedAction,
@@ -136,9 +136,7 @@ import           Development.IDE.Graph.Database         (ShakeDatabase,
                                                          shakeGetDatabaseKeys,
                                                          shakeNewDatabase,
                                                          shakeProfileDatabase,
-                                                         shakeRunDatabaseForKeys,
-                                                         shakeGetDirtySet,
-                                                         getDatabaseDirtyKeys)
+                                                         shakeRunDatabaseForKeys)
 import           Development.IDE.Graph.Rule
 import           Development.IDE.Types.Action
 import           Development.IDE.Types.Diagnostics
@@ -185,7 +183,7 @@ import           Development.IDE.GHC.Compat             (mkSplitUniqSupply,
 data Log
   = LogCreateHieDbExportsMapStart
   | LogCreateHieDbExportsMapFinish !Int
-  | LogBuildSessionRestart !String ![DelayedActionInternal] ![Key] !Seconds !(Maybe FilePath)
+  | LogBuildSessionRestart !String ![DelayedActionInternal] !KeySet !Seconds !(Maybe FilePath)
   | LogBuildSessionRestartTakingTooLong !Seconds
   | LogDelayedAction !(DelayedAction ()) !Seconds
   | LogBuildSessionFinish !(Maybe SomeException)
@@ -210,7 +208,7 @@ instance Pretty Log where
       vcat
         [ "Restarting build session due to" <+> pretty reason
         , "Action Queue:" <+> pretty (map actionName actionQueue)
-        , "Keys:" <+> pretty (map show $ keyBackLog)
+        , "Keys:" <+> pretty (map show $ toListKeySet keyBackLog)
         , "Aborting previous build session took" <+> pretty (showDuration abortDuration) <+> pretty shakeProfilePath ]
     LogBuildSessionRestartTakingTooLong seconds ->
         "Build restart is taking too long (" <> pretty seconds <> " seconds)"
@@ -276,7 +274,7 @@ data ShakeExtras = ShakeExtras
     ,globals :: TVar (HMap.HashMap TypeRep Dynamic)
       -- ^ Registry of global state used by rules.
       -- Small and immutable after startup, so not worth using an STM.Map.
-    ,ruleState :: Values
+    ,state :: Values
     ,diagnostics :: STMDiagnosticStore
     ,hiddenDiagnostics :: STMDiagnosticStore
     ,publishedDiagnostics :: STM.Map NormalizedUri [Diagnostic]
@@ -329,6 +327,8 @@ data ShakeExtras = ShakeExtras
     -- We don't need a STM.Map because we never update individual keys ourselves.
     , defaultConfig :: Config
       -- ^ 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
     }
 
 type WithProgressFunc = forall a.
@@ -447,7 +447,7 @@ getIdeOptionsIO ide = do
 -- | Return the most recent, potentially stale, value and a PositionMapping
 -- for the version of that value.
 lastValueIO :: IdeRule k v => ShakeExtras -> k -> NormalizedFilePath -> IO (Maybe (v, PositionMapping))
-lastValueIO s@ShakeExtras{positionMapping,persistentKeys,ruleState} k file = do
+lastValueIO s@ShakeExtras{positionMapping,persistentKeys,state} k file = do
 
     let readPersistent
           | IdeTesting testing <- ideTesting s -- Don't read stale persistent values in tests
@@ -461,7 +461,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,ruleState} k file = do
             MaybeT $ pure $ (,del,ver) <$> fromDynamic dv
           case mv of
             Nothing -> atomicallyNamed "lastValueIO 1" $ do
-                STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) ruleState
+                STM.focus (Focus.alter (alterValue $ Failed True)) (toKey k file) state
                 return Nothing
             Just (v,del,mbVer) -> do
                 actual_version <- case mbVer of
@@ -469,7 +469,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,ruleState} k file = do
                   Nothing -> (Just . ModificationTime <$> getModTime (fromNormalizedFilePath file))
                               `catch` (\(_ :: IOException) -> pure Nothing)
                 atomicallyNamed "lastValueIO 2" $ do
-                  STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) ruleState
+                  STM.focus (Focus.alter (alterValue $ Stale (Just del) actual_version (toDyn v))) (toKey k file) state
                   Just . (v,) . addOldDelta del <$> mappingForVersion positionMapping file actual_version
 
         -- We got a new stale value from the persistent rule, insert it in the map without affecting diagnostics
@@ -480,7 +480,7 @@ lastValueIO s@ShakeExtras{positionMapping,persistentKeys,ruleState} k file = do
           -- Something already succeeded before, leave it alone
           _        -> old
 
-    atomicallyNamed "lastValueIO 4"  (STM.lookup (toKey k file) ruleState) >>= \case
+    atomicallyNamed "lastValueIO 4"  (STM.lookup (toKey k file) state) >>= \case
       Nothing -> readPersistent
       Just (ValueWithDiagnostics value _) -> case value of
         Succeeded ver (fromDynamic -> Just v) ->
@@ -564,10 +564,20 @@ deleteValue
   -> k
   -> NormalizedFilePath
   -> STM [Key]
-deleteValue ShakeExtras{ruleState} key file = do
-    STM.delete (toKey key file) ruleState
+deleteValue ShakeExtras{dirtyKeys, state} key file = do
+    STM.delete (toKey key file) state
     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.
@@ -661,6 +671,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
         actionQueue <- newQueue
 
         let clientCapabilities = maybe def LSP.resClientCapabilities lspEnv
+        dirtyKeys <- newTVarIO mempty
         -- Take one VFS snapshot at the start
         vfsVar <- newTVarIO =<< vfsSnapshot lspEnv
         pure ShakeExtras{shakeRecorder = recorder, ..}
@@ -680,7 +691,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
 
     -- monitoring
     let readValuesCounter = fromIntegral . countRelevantKeys checkParents <$> getStateKeys shakeExtras
-        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDirtySet shakeDb
+        readDirtyKeys = fromIntegral . countRelevantKeys checkParents . toListKeySet <$> readTVarIO(dirtyKeys shakeExtras)
         readIndexPending = fromIntegral . HMap.size <$> readTVarIO (indexPending $ hiedbWriter shakeExtras)
         readExportsMap = fromIntegral . ExportsMap.exportsMapSize <$> readTVarIO (exportsMap shakeExtras)
         readDatabaseCount = fromIntegral . countRelevantKeys checkParents . map fst <$> shakeGetDatabaseKeys shakeDb
@@ -700,7 +711,7 @@ shakeOpen recorder lspEnv defaultConfig idePlugins debouncer
 
 
 getStateKeys :: ShakeExtras -> IO [Key]
-getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . ruleState
+getStateKeys = (fmap.fmap) fst . atomically . ListT.toList . STM.listT . state
 
 -- | Must be called in the 'Initialized' handler and only once
 shakeSessionInit :: Recorder (WithPriority Log) -> IdeState -> IO ()
@@ -708,7 +719,7 @@ shakeSessionInit recorder ide@IdeState{..} = do
     -- Take a snapshot of the VFS - it should be empty as we've received no notifications
     -- till now, but it can't hurt to be in sync with the `lsp` library.
     vfs <- vfsSnapshot (lspEnv shakeExtras)
-    initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit" []
+    initSession <- newSession recorder shakeExtras (VFSModified vfs) shakeDb [] "shakeSessionInit"
     putMVar shakeSession initSession
     logWith recorder Debug LogSessionInitialised
 
@@ -754,19 +765,20 @@ shakeRestart recorder IdeState{..} vfs reason acts ioActionBetweenShakeSession =
         shakeSession
         (\runner -> do
               (stopTime,()) <- duration $ logErrorAfter 10 $ cancelShakeSession runner
-              dirtyKeys <- ioActionBetweenShakeSession
+              keys <- ioActionBetweenShakeSession
+              join $ atomically $ recordDirtyKeys shakeExtras 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 dirtyKeys stopTime res
-              return dirtyKeys
+              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
-        (\dirtyKeys -> do
-          (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason dirtyKeys)
+        (\() -> do
+          (,()) <$> newSession recorder shakeExtras vfs shakeDb acts reason)
     where
         logErrorAfter :: Seconds -> IO () -> IO ()
         logErrorAfter seconds action = flip withAsync (const action) $ do
@@ -806,9 +818,8 @@ newSession
     -> ShakeDatabase
     -> [DelayedActionInternal]
     -> String
-    -> [Key]
     -> IO ShakeSession
-newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason theDirtyKeys = do
+newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
 
     -- Take a new VFS snapshot
     case vfsMod of
@@ -817,7 +828,10 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason theDirtyKe
 
     IdeOptions{optRunSubset} <- getIdeOptionsIO extras
     reenqueued <- atomicallyNamed "actionQueue - peek" $ peekInProgress actionQueue
-    let allPendingKeys = if optRunSubset then Just theDirtyKeys else Nothing
+    allPendingKeys <-
+        if optRunSubset
+          then Just <$> readTVarIO dirtyKeys
+          else return Nothing
     let
         -- A daemon-like action used to inject additional work
         -- Runs actions from the work queue sequentially
@@ -838,10 +852,10 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason theDirtyKe
         workRun restore = withSpan "Shake session" $ \otSpan -> do
           setTag otSpan "reason" (fromString reason)
           setTag otSpan "queue" (fromString $ unlines $ map actionName reenqueued)
-          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show kk)
+          whenJust allPendingKeys $ \kk -> setTag otSpan "keys" (BS8.pack $ unlines $ map show $ toListKeySet kk)
           let keysActs = pumpActionThread otSpan : map (run otSpan) (reenqueued ++ acts)
           res <- try @SomeException $
-            restore $ shakeRunDatabaseForKeys allPendingKeys shakeDb keysActs
+            restore $ shakeRunDatabaseForKeys (toListKeySet <$> allPendingKeys) shakeDb keysActs
           return $ do
               let exception =
                     case res of
@@ -910,10 +924,9 @@ garbageCollectDirtyKeysOlderThan maxAge checkParents = otTracedGarbageCollection
 garbageCollectKeys :: String -> Int -> CheckParents -> [(Key, Int)] -> Action [Key]
 garbageCollectKeys label maxAge checkParents agedKeys = do
     start <- liftIO offsetTime
-    ShakeExtras{ruleState, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras
-    dirtyKeys <- getDatabaseDirtyKeys
+    ShakeExtras{state, dirtyKeys, lspEnv, shakeRecorder, ideTesting} <- getShakeExtras
     (n::Int, garbage) <- liftIO $
-        foldM (removeDirtyKey dirtyKeys ruleState) (0,[]) agedKeys
+        foldM (removeDirtyKey dirtyKeys state) (0,[]) agedKeys
     t <- liftIO start
     when (n>0) $ liftIO $ do
         logWith shakeRecorder Debug $ LogShakeGarbageCollection (T.pack label) n t
@@ -1047,8 +1060,8 @@ useWithStaleFast' key file = do
   -- keep updating the value in the key.
   waitValue <- delayedAction $ mkDelayedAction ("C:" ++ show key ++ ":" ++ fromNormalizedFilePath file) Debug $ use key file
 
-  s@ShakeExtras{ruleState} <- askShake
-  r <- liftIO $ atomicallyNamed "useStateFast" $ getValues ruleState key file
+  s@ShakeExtras{state} <- askShake
+  r <- liftIO $ atomicallyNamed "useStateFast" $ getValues state key file
   liftIO $ case r of
     -- block for the result if we haven't computed before
     Nothing -> do
@@ -1175,12 +1188,12 @@ defineEarlyCutoff'
     -> (Value v -> Action (Maybe BS.ByteString, IdeResult v))
     -> Action (RunResult (A (RuleResult k)))
 defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
-    ShakeExtras{ruleState, progress} <- getShakeExtras
+    ShakeExtras{state, progress, dirtyKeys} <- getShakeExtras
     options <- getIdeOptions
     (if optSkipProgress options key then id else inProgress progress file) $ do
         val <- case mbOld of
             Just old | mode == RunDependenciesSame -> do
-                mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues ruleState key file
+                mbValue <- liftIO $ atomicallyNamed "define - read 1" $ getValues state key file
                 case mbValue of
                     -- No changes in the dependencies and we have
                     -- an existing successful result.
@@ -1196,7 +1209,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
         res <- case val of
             Just res -> return res
             Nothing -> do
-                staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues ruleState key file <&> \case
+                staleV <- liftIO $ atomicallyNamed "define -read 3" $ getValues state key file <&> \case
                     Nothing                   -> Failed False
                     Just (Succeeded ver v, _) -> Stale Nothing ver v
                     Just (Stale d ver v, _)   -> Stale d ver v
@@ -1222,7 +1235,7 @@ defineEarlyCutoff' doDiagnostics cmp key file mbOld mode action = do
                     (if eq then ChangedRecomputeSame else ChangedRecomputeDiff)
                     (encodeShakeValue bs)
                     (A res)
-                    (setValues ruleState key file res (Vector.fromList diags))
+                    (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/Plugin/Test.hs b/ghcide/src/Development/IDE/Plugin/Test.hs
index 22ab3c7482..5dfc8460b0 100644
--- a/ghcide/src/Development/IDE/Plugin/Test.hs
+++ b/ghcide/src/Development/IDE/Plugin/Test.hs
@@ -131,7 +131,7 @@ testRequestHandler s (GarbageCollectDirtyKeys parents age) = do
     res <- liftIO $ runAction "garbage collect dirty" s $ garbageCollectDirtyKeysOlderThan age parents
     return $ Right $ toJSON $ map show res
 testRequestHandler s GetStoredKeys = do
-    keys <- liftIO $ atomically $ map fst <$> ListT.toList (STM.listT $ ruleState $ shakeExtras s)
+    keys <- liftIO $ atomically $ map fst <$> ListT.toList (STM.listT $ state $ shakeExtras s)
     return $ Right $ toJSON $ map show keys
 testRequestHandler s GetFilesOfInterest = do
     ff <- liftIO $ getFilesOfInterest s
diff --git a/hls-graph/src/Development/IDE/Graph/Database.hs b/hls-graph/src/Development/IDE/Graph/Database.hs
index 1551b163ef..bd8601cd16 100644
--- a/hls-graph/src/Development/IDE/Graph/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Database.hs
@@ -8,9 +8,8 @@ module Development.IDE.Graph.Database(
     shakeGetBuildStep,
     shakeGetDatabaseKeys,
     shakeGetDirtySet,
-    shakeGetCleanKeys,
-    getDatabaseDirtyKeys,
-    shakeGetBuildEdges) where
+    shakeGetCleanKeys
+    ,shakeGetBuildEdges) where
 import           Control.Concurrent.STM.Stats            (readTVarIO)
 import           Data.Dynamic
 import           Data.Maybe
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
index 415fd28fee..8d956e74c9 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -47,7 +47,6 @@ newDatabase :: Dynamic -> TheRules -> IO Database
 newDatabase databaseExtra databaseRules = do
     databaseStep <- newTVarIO $ Step 0
     databaseValues <- atomically SMap.new
-    databaseDirtyKeys <- newTVarIO mempty
     pure Database{..}
 
 -- | Increment the step and mark dirty.
@@ -61,9 +60,7 @@ incDatabase db (Just kk) = do
         -- Updating all the keys atomically is not necessary
         -- since we assume that no build is mutating the db.
         -- Therefore run one transaction per key to minimise contention.
-        atomicallyNamed "incDatabase" $ do
-            modifyTVar' (databaseDirtyKeys db) (insertKeySet k)
-            SMap.focus updateDirty k (databaseValues db)
+        atomicallyNamed "incDatabase" $ SMap.focus updateDirty k (databaseValues db)
 
 -- all keys are dirty
 incDatabase db Nothing = do
@@ -123,7 +120,6 @@ builder db@Database{..} stack keys = withRunInIO $ \(RunInIO run) -> do
                     let act = run (refresh db stack id s)
                         (force, val) = splitIO (join act)
                     SMap.focus (updateStatus $ Running current force val s) id databaseValues
-
                     modifyTVar' toForce (Spawn force:)
                     pure val
 
@@ -204,9 +200,7 @@ compute db@Database{..} stack key mode result = do
                     (getResultDepsDefault mempty previousDeps)
                     deps
         _ -> pure ()
-
     atomicallyNamed "compute and run hook" $ do
-        modifyTVar' databaseDirtyKeys (deleteKeySet key)
         runHook
         SMap.focus (updateStatus $ Clean res) key databaseValues
     pure res
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
index 3ba276ffb0..3474289b42 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
@@ -28,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)
@@ -108,13 +107,9 @@ data Database = Database {
     databaseExtra  :: Dynamic,
     databaseRules  :: TheRules,
     databaseStep   :: !(TVar Step),
-    databaseValues :: !(Map Key KeyDetails),
-    databaseDirtyKeys :: !(TVar KeySet)
+    databaseValues :: !(Map Key KeyDetails)
     }
 
-getDatabaseDirtyKeys :: Action (TVar KeySet)
-getDatabaseDirtyKeys = Action $ asks (databaseDirtyKeys . actionDatabase)
-
 getDatabaseValues :: Database -> IO [(Key, Status)]
 getDatabaseValues = atomically
                   . (fmap.fmap) (second keyStatus)
@@ -212,9 +207,6 @@ data RunResult value = RunResult
         -- ^ The hook to run after the rule completes.
     } deriving Functor
 
-instance NFData value => NFData (RunResult value) where
-    rnf (RunResult x1 x2 x3 _) = rnf x1 `seq` x2 `seq` rnf x3
-
 ---------------------------------------------------------------------
 -- EXCEPTIONS
 

From fccc789d83398a5440beec309999871323690ca8 Mon Sep 17 00:00:00 2001
From: Patrick <fwy996602672@gmail.com>
Date: Tue, 30 Apr 2024 21:37:19 +0800
Subject: [PATCH 5/9] simplify database

---
 .../src/Development/IDE/Graph/Internal/Database.hs   | 12 ++++++------
 1 file changed, 6 insertions(+), 6 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..0428f99eb6 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -153,21 +153,21 @@ refreshDeps visited db stack key result = \case
         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 pure $ 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 pure $ 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}) -> fmap join $ asyncWithCleanUp $ refreshDeps mempty db stack key me (reverse deps)
     (Right stack, _) ->
         asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
 

From 297c4421050a268beb0362dc2864bb7c1f755edf Mon Sep 17 00:00:00 2001
From: Patrick <fwy996602672@gmail.com>
Date: Tue, 30 Apr 2024 21:59:50 +0800
Subject: [PATCH 6/9] computeWithCleanup

---
 .../src/Development/IDE/Graph/Internal/Database.hs  | 13 ++++++++-----
 1 file changed, 8 insertions(+), 5 deletions(-)

diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
index 0428f99eb6..6318a48d4d 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -146,30 +146,33 @@ isDirty me = any (\(_,dep) -> resultBuilt me < resultChanged dep)
 refreshDeps :: KeySet -> Database -> Stack -> Key -> Result -> [KeySet] -> AIO (IO Result)
 refreshDeps visited db stack key result = \case
     -- no more deps to refresh
-    [] -> pure $ compute db stack key RunDependenciesSame (Just result)
+    [] -> computeWithCleanup 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 pure $ compute db stack key RunDependenciesChanged (Just result)
+                then computeWithCleanup db stack key RunDependenciesChanged (Just result)
                 -- else kick the rest of the deps
                 else refreshDeps newVisited db stack key result deps
             Right iores -> do
                 res <- liftIO iores
                 if isDirty result res
-                    then pure $ compute db stack key RunDependenciesChanged (Just result)
+                    then computeWithCleanup db stack key RunDependenciesChanged (Just result)
                     else refreshDeps newVisited db stack key result deps
 
+computeWithCleanup :: Database -> Stack -> Key -> RunMode -> Maybe Result -> AIO (IO Result)
+computeWithCleanup db stack key a b = asyncWithCleanUp $ liftIO $  compute db stack key a b
+
 -- | 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}) -> fmap join $ asyncWithCleanUp $ refreshDeps mempty db stack key me (reverse deps)
+    (Right stack, Just me@Result{resultDeps = ResultDeps deps}) -> refreshDeps mempty db stack key me (reverse deps)
     (Right stack, _) ->
-        asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
+        computeWithCleanup db stack key RunDependenciesChanged result
 
 -- | Compute a key.
 compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result

From 9cfb45749294b7e8b5cb56f160fbb58c7665cb15 Mon Sep 17 00:00:00 2001
From: Patrick <fwy996602672@gmail.com>
Date: Tue, 30 Apr 2024 23:09:18 +0800
Subject: [PATCH 7/9] cleanup refreshDeps

---
 .../Development/IDE/Graph/Internal/Database.hs    | 15 ++++++---------
 1 file changed, 6 insertions(+), 9 deletions(-)

diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
index 6318a48d4d..7f2cee0a8c 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -143,36 +143,33 @@ 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
-    [] -> computeWithCleanup 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 computeWithCleanup 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 -> do
                 res <- liftIO iores
                 if isDirty result res
-                    then computeWithCleanup db stack key RunDependenciesChanged (Just result)
+                    then liftIO $ compute db stack key RunDependenciesChanged (Just result)
                     else refreshDeps newVisited db stack key result deps
 
-computeWithCleanup :: Database -> Stack -> Key -> RunMode -> Maybe Result -> AIO (IO Result)
-computeWithCleanup db stack key a b = asyncWithCleanUp $ liftIO $  compute db stack key a b
-
 -- | 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, _) ->
-        computeWithCleanup db stack key RunDependenciesChanged result
+        asyncWithCleanUp $ liftIO $ compute db stack key RunDependenciesChanged result
 
 -- | Compute a key.
 compute :: Database -> Stack -> Key -> RunMode -> Maybe Result -> IO Result

From 0e4b83e7b9861ace8f7898d050f13c3487b7b5dc Mon Sep 17 00:00:00 2001
From: Patrick <fwy996602672@gmail.com>
Date: Wed, 1 May 2024 02:52:32 +0800
Subject: [PATCH 8/9] add applicative to hls-graph

---
 ghcide/src/Development/IDE/Core/Rules.hs      | 12 +++--
 ghcide/src/Development/IDE/Core/Shake.hs      | 49 +++++++++++++++++++
 .../Development/IDE/Graph/Internal/Action.hs  | 47 +++++++++++++++++-
 .../IDE/Graph/Internal/Database.hs            | 43 +++++++++++++++-
 .../Development/IDE/Graph/Internal/Rules.hs   | 39 +++++++++++++++
 .../Development/IDE/Graph/Internal/Types.hs   | 10 ++++
 6 files changed, 193 insertions(+), 7 deletions(-)

diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs
index 1e96a99f2b..5eb53cdc5f 100644
--- a/ghcide/src/Development/IDE/Core/Rules.hs
+++ b/ghcide/src/Development/IDE/Core/Rules.hs
@@ -179,6 +179,7 @@ import           GHC                                          (mgModSummaries)
 
 #if MIN_VERSION_ghc(9,3,0)
 import qualified Data.IntMap                                  as IM
+import Development.IDE.Graph.Internal.Action (runEval)
 #endif
 
 
@@ -611,12 +612,17 @@ readHieFileFromDisk recorder hie_loc = do
     Right _ -> liftIO $ logWith recorder Logger.Debug $ LogLoadingHieFileSuccess hie_loc
   except res
 
+seqTup :: (Functor f, Applicative f) => (f a, f b, f c) -> f (a, b, c)
+seqTup (a, b, c) = (,,) <$> a <*> b <*> c
+
 -- | Typechecks a module.
 typeCheckRule :: Recorder (WithPriority Log) -> Rules ()
 typeCheckRule recorder = define (cmapWithPrio LogShake recorder) $ \TypeCheck file -> do
-    pm <- use_ GetParsedModule file
-    hsc  <- hscEnv <$> use_ GhcSessionDeps file
-    foi <- use_ IsFileOfInterest file
+    let pmA = useEval_ GetParsedModule file
+    let hscA = fmap hscEnv <$> useEval_ GhcSessionDeps file
+    let foiA = useEval_ IsFileOfInterest file
+    tup <- (,,) <$> pmA <*> hscA <*> foiA
+    (pm, hsc, foi) <- runEval $ seqTup tup
     -- We should only call the typecheck rule for files of interest.
     -- Keeping typechecked modules in memory for other files is
     -- very expensive.
diff --git a/ghcide/src/Development/IDE/Core/Shake.hs b/ghcide/src/Development/IDE/Core/Shake.hs
index 0d1eb3ea60..47c35f8f8f 100644
--- a/ghcide/src/Development/IDE/Core/Shake.hs
+++ b/ghcide/src/Development/IDE/Core/Shake.hs
@@ -73,6 +73,7 @@ module Development.IDE.Core.Shake(
     garbageCollectDirtyKeysOlderThan,
     Log(..),
     VFSModified(..), getClientConfigAction,
+    useEval_
     ) where
 
 import           Control.Concurrent.Async
@@ -172,6 +173,11 @@ import qualified StmContainers.Map                      as STM
 import           System.FilePath                        hiding (makeRelative)
 import           System.IO.Unsafe                       (unsafePerformIO)
 import           System.Time.Extra
+import Development.IDE.Graph.Internal.Action (apply', AEval, applyEval)
+import Development.IDE.Graph.Internal.Rules
+import GHC.Base (undefined)
+import Data.Maybe (fromMaybe)
+import Control.Monad (sequence)
 -- See Note [Guidelines For Using CPP In GHCIDE Import Statements]
 
 #if !MIN_VERSION_ghc(9,3,0)
@@ -1105,11 +1111,54 @@ uses_ key files = do
         Nothing -> liftIO $ throwIO $ BadDependency (show key)
         Just v  -> return v
 
+useEval_ :: IdeRule k v => k -> NormalizedFilePath -> Action (AEval v)
+useEval_ key file = fmap runIdentity <$> usesEval_ key (Identity file)
+
+usesEval_ :: (Traversable f, IdeRule k v) => k -> f NormalizedFilePath -> Action (AEval (f v))
+usesEval_ key files = do
+    res <- usesEval key files
+    case sequence $ fmap sequence res of
+        Nothing -> liftIO $ throwIO $ BadDependency (show key)
+        Just v  -> return v
+
+
+usesEval :: (Traversable f, IdeRule k v)
+    => k -> f NormalizedFilePath -> Action (AEval (f (Maybe v)))
+usesEval key files = (fmap . fmap) (\(A value) -> currentValue value) <$> applyEval (fmap (Q . (key,)) files)
+
 -- | Plural version of 'use'
 uses :: (Traversable f, IdeRule k v)
     => k -> f NormalizedFilePath -> Action (f (Maybe v))
 uses key files = fmap (\(A value) -> currentValue value) <$> apply (fmap (Q . (key,)) files)
 
+-- go :: '[Int]
+-- go = [1]
+
+class CurrentValues keys where
+    type HFmap (f :: * -> *) keys :: [*]
+    currentValues :: HList keys -> HList (HFmap Maybe keys)
+instance CurrentValues '[] where
+    type HFmap f '[] = '[]
+    currentValues HNil = HNil
+instance (CurrentValues xs) => CurrentValues (A x ': xs) where
+    type HFmap f (A x ': xs) = f x ': HFmap f xs
+    currentValues (HCons (A x) b) = HCons (currentValue x) (currentValues b)
+
+-- class UnMaybe keys where
+--     unMaybe :: HList (HFmap Maybe (RunResults keys)) -> HList (RunResults keys)
+    -- unMaybe
+    -- unMaybe (HCons Nothing xs) = unMaybe xs
+
+
+uses'_ :: (CurrentValues (RunResults keys), HListKeys keys,  HListValues (RunResults keys)) => HList keys -> Action (HList (RunResults keys))
+uses'_ = undefined
+-- uses_' :: (CurrentValues (RunResults keys), HListKeys keys,  HListValues (RunResults keys))
+--     => HList keys -> Action (HList (RunResults keys))
+-- uses_' ks = fmap currentValues $ apply' ks
+
+uses' :: (CurrentValues (RunResults keys), HListKeys keys,  HListValues (RunResults keys)) => HList keys -> Action (HList (HFmap Maybe (RunResults keys)))
+uses' ks = fmap currentValues $ apply' ks
+
 -- | Return the last computed result which might be stale.
 usesWithStale :: (Traversable f, IdeRule k v)
     => k -> f NormalizedFilePath -> Action (f (Maybe (v, PositionMapping)))
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
index 6d47d9b511..8060634f36 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
@@ -9,9 +9,13 @@ module Development.IDE.Graph.Internal.Action
 , alwaysRerun
 , apply1
 , apply
+, apply'
 , applyWithoutDependency
 , parallel
 , runActions
+, AEval(..)
+, applyEval
+, runEval
 , Development.IDE.Graph.Internal.Action.getDirtySet
 , getKeysAndVisitedAge
 ) where
@@ -28,9 +32,10 @@ import           Data.IORef
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Database
 import           Development.IDE.Graph.Internal.Key
-import           Development.IDE.Graph.Internal.Rules    (RuleResult)
+import           Development.IDE.Graph.Internal.Rules
 import           Development.IDE.Graph.Internal.Types
 import           System.Exit
+import GHC.Conc (par)
 
 type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 
@@ -110,12 +115,50 @@ actionFinally a b = do
 apply1 :: (RuleResult key ~ value, ShakeValue key, Typeable value) => key -> Action value
 apply1 k = runIdentity <$> apply (Identity k)
 
+-- apply' :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
+apply' :: (HListKeys keys, HListValues (RunResults keys)) => HList keys -> Action (HList (RunResults keys))
+apply' ks = do
+    db <- Action $ asks actionDatabase
+    stack <- Action $ asks actionStack
+    (is, vs) <- liftIO $ build1 db stack ks
+    ref <- Action $ asks actionDeps
+    let !ks = force $ fromListKeySet $ toList is
+    liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
+    pure vs
+
+data AEval a = AEval KeySet a
+
+instance Foldable AEval where
+    foldMap f (AEval _ x) = f x
+instance Traversable AEval where
+    traverse f (AEval k x) = AEval k <$> f x
+instance Functor AEval where
+    fmap f (AEval k x) = AEval k $ f x
+
+instance Applicative AEval where
+    pure x = AEval mempty x
+    AEval ks1 f <*> AEval ks2 x = x `par` f `seq` AEval (ks1 <> ks2) $ f x
+
+applyEval :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (AEval (f value))
+applyEval ks = do
+    db <- Action $ asks actionDatabase
+    stack <- Action $ asks actionStack
+    (is, vs) <- liftIO $ build db stack ks
+    let ks = force $ fromListKeySet $ toList is
+    pure $ AEval ks vs
+
+runEval :: AEval value -> Action value
+runEval (AEval ks vs) = do
+    ref <- Action $ asks actionDeps
+    liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
+    pure vs
+
 apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
 apply ks = do
     db <- Action $ asks actionDatabase
     stack <- Action $ asks actionStack
-    (is, vs) <- liftIO $ build db stack ks
     ref <- Action $ asks actionDeps
+    (is, vs) <- liftIO $ build db stack ks
     let !ks = force $ fromListKeySet $ toList is
     liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
     pure vs
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
index 7f2cee0a8c..4fa630a5dc 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Database.hs
@@ -7,7 +7,7 @@
 {-# LANGUAGE RecordWildCards    #-}
 {-# LANGUAGE TypeFamilies       #-}
 
-module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge) where
+module Development.IDE.Graph.Internal.Database (newDatabase, incDatabase, build, getDirtySet, getKeysAndVisitAge, build1) where
 
 import           Prelude                              hiding (unzip)
 
@@ -41,6 +41,7 @@ import qualified ListT
 import qualified StmContainers.Map                    as SMap
 import           System.IO.Unsafe
 import           System.Time.Extra                    (duration, sleep)
+import Data.Kind (Type)
 
 
 newDatabase :: Dynamic -> TheRules -> IO Database
@@ -76,6 +77,10 @@ updateDirty = Focus.adjust $ \(KeyDetails status rdeps) ->
                   | Clean x <- status = Dirty (Just x)
                   | otherwise = status
             in KeyDetails status' rdeps
+
+
+
+
 -- | Unwrap and build a list of keys in parallel
 build
     :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)
@@ -93,6 +98,40 @@ build db stack keys = do
         asV :: Value -> value
         asV (Value x) = unwrapDynamic x
 
+
+-- build2 :: (HListKeys keys, HListValues values, values ~ RunResults keys) => Database -> Stack -> HList keys -> IO ([Key], HList values)
+-- build2 :: (Traversable f, Typeable a, Hashable a, Show a) => Database -> Stack -> f a -> AIO (f (Key, Result))
+
+build2
+    :: forall f key value . (Traversable f, RuleResult key ~ value, Typeable key, Show key, Hashable key, Eq key, Typeable value)
+    => Database -> Stack -> f key -> AIO (f Key, f value)
+build2 db stack keys = do
+    built <- builder db stack (fmap newKey keys)
+    built2 <- case built of
+                Left clean  -> return clean
+                Right dirty -> liftIO dirty
+    let (ids, vs) = unzip built2
+    pure (ids, fmap (asV . resultValue) vs)
+    where
+        asV :: Value -> value
+        asV (Value x) = unwrapDynamic x
+
+build1 :: (HListKeys keys, HListValues values, values ~ RunResults keys) => Database -> Stack -> HList keys -> IO ([Key], HList values)
+build1 db stack hKeys = do
+    built <- runAIO $ do
+        built <- builder db stack (fmap newKey keys)
+        case built of
+          Left clean  -> return clean
+          Right dirty -> liftIO dirty
+    let (ids, vs) = unzip built
+    pure (ids, listHList $ fmap (asV . resultValue) vs)
+    where
+        asV (Value x) = unwrapDynamic x
+        keys = hListList hKeys
+
+
+-- builder1 :: Traversable f => Database -> Stack -> f Key -> AIO (IO (f (Key, Result)))
+
 -- | Build a list of keys and return their results.
 --  If none of the keys are dirty, we can return the results immediately.
 --  Otherwise, a blocking computation is returned *which must be evaluated asynchronously* to avoid deadlock.
@@ -151,7 +190,7 @@ refreshDeps visited db stack key result = \case
         let newVisited = dep <> visited
         res <- builder db stack (toListKeySet (dep `differenceKeySet` visited))
         case res of
-            Left res ->  if isDirty result res
+            Left res -> if isDirty result res
                 -- restart the computation if any of the deps are dirty
                 then liftIO $ compute db stack key RunDependenciesChanged (Just result)
                 -- else kick the rest of the deps
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs
index 9a5f36ca35..0f0a0cca0f 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Rules.hs
@@ -19,9 +19,48 @@ import           Data.Typeable
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Types
+import Data.Kind (Type)
 
 -- | The type mapping between the @key@ or a rule and the resulting @value@.
 type family RuleResult key -- = value
+type family RunResults keys where
+    RunResults '[] = '[]
+    RunResults (x ': xs) = RunResult x ': RunResults xs
+
+-- type family MapListType f keys where
+--     MapListType _ '[] = '[]
+--     MapListType f (x ': xs) = f x ': MapListType f xs
+
+-- type family MapResults as bs where
+    -- MapResults '[] = '[]
+    -- MapResults (a ': as) = RunResult a ': MapResults as
+
+class HMap f as where
+    hMap :: f -> HList as -> HList (RunResults as)
+
+type IsKey a = (Typeable a, Hashable a, Show a)
+
+data HList :: [Type] -> Type where
+    HNil :: HList '[]
+    HCons :: a -> HList as -> HList (a ': as)
+
+class HListKeys as where
+    hListList :: HList as -> [Key]
+instance HListKeys '[] where
+    hListList HNil = []
+instance (IsKey a, HListKeys as) => HListKeys (a ': as) where
+    hListList (HCons k xs) = newKey k : hListList xs
+
+
+class HListValues as where
+    listHList :: [Dynamic] -> HList as
+instance HListValues '[] where
+    listHList [] = HNil
+    listHList _ = error "listHList: too many elements"
+instance (Typeable a, HListValues as) => HListValues (a ': as) where
+    listHList  [] = error "listHList: empty list"
+    listHList (x:xs) = HCons (unwrapDynamic x) (listHList xs)
+
 
 action :: Action a -> Rules ()
 action x = do
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
index 3474289b42..f5dee8afad 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
@@ -69,12 +69,22 @@ data SRules = SRules {
 newtype Action a = Action {fromAction :: ReaderT SAction IO a}
     deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
 
+
 data SAction = SAction {
     actionDatabase :: !Database,
     actionDeps     :: !(IORef ResultDeps),
     actionStack    :: !Stack
     }
 
+-- newtype FAction a = FAction {fromFAction :: ReaderT FSAction IO a}
+--     deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
+
+-- data FSAction = FSAction {
+--     factionDatabase :: !Database,
+--     factionDeps     :: !ResultDeps,
+--     factionStack    :: !Stack
+--     }
+
 getDatabase :: Action Database
 getDatabase = Action $ asks actionDatabase
 

From e6806e27d1fe2572288b1421e2e49e79158e1134 Mon Sep 17 00:00:00 2001
From: Patrick <fwy996602672@gmail.com>
Date: Wed, 1 May 2024 04:09:53 +0800
Subject: [PATCH 9/9] record right after

---
 .../src/Development/IDE/Graph/Internal/Action.hs      | 11 +++++++----
 hls-graph/src/Development/IDE/Graph/Internal/Types.hs |  4 ++++
 2 files changed, 11 insertions(+), 4 deletions(-)

diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
index 8060634f36..236a1e0f37 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Action.hs
@@ -36,6 +36,7 @@ import           Development.IDE.Graph.Internal.Rules
 import           Development.IDE.Graph.Internal.Types
 import           System.Exit
 import GHC.Conc (par)
+import Debug.Trace (traceM, trace)
 
 type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 
@@ -137,7 +138,7 @@ instance Functor AEval where
 
 instance Applicative AEval where
     pure x = AEval mempty x
-    AEval ks1 f <*> AEval ks2 x = x `par` f `seq` AEval (ks1 <> ks2) $ f x
+    AEval ks1 f <*> AEval ks2 x = x `par` f `par` AEval (ks1 <> ks2) $ f x
 
 applyEval :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (AEval (f value))
 applyEval ks = do
@@ -145,12 +146,14 @@ applyEval ks = do
     stack <- Action $ asks actionStack
     (is, vs) <- liftIO $ build db stack ks
     let ks = force $ fromListKeySet $ toList is
+    traceM $ "[TRACE]: applyEval: " ++ show ks
+    ref <- Action $ asks actionDeps
+    liftIO $ modifyIORef' ref (mergeWithFirst ks)
     pure $ AEval ks vs
 
 runEval :: AEval value -> Action value
-runEval (AEval ks vs) = do
-    ref <- Action $ asks actionDeps
-    liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
+runEval (AEval ks vs) = trace "runEval" $ do
+    traceM $ "[TRACE]: runEval: " ++ show ks
     pure vs
 
 apply :: (Traversable f, RuleResult key ~ value, ShakeValue key, Typeable value) => f key -> Action (f value)
diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
index f5dee8afad..26b343cb80 100644
--- a/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
+++ b/hls-graph/src/Development/IDE/Graph/Internal/Types.hs
@@ -168,6 +168,10 @@ getResultDepsDefault _ (ResultDeps ids)      = fold ids
 getResultDepsDefault _ (AlwaysRerunDeps ids) = ids
 getResultDepsDefault def UnknownDeps         = def
 
+mergeWithFirst :: KeySet -> ResultDeps -> ResultDeps
+mergeWithFirst ks (ResultDeps (x:xs)) = ResultDeps (ks <> x : xs)
+mergeWithFirst ks x = ResultDeps [ks] <> x
+
 mapResultDeps :: (KeySet -> KeySet) -> ResultDeps -> ResultDeps
 mapResultDeps f (ResultDeps ids)      = ResultDeps $ fmap f ids
 mapResultDeps f (AlwaysRerunDeps ids) = AlwaysRerunDeps $ f ids