fix the race between cache value updated but not updated hls-database

Author: soulomoon

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

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 ())

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 ()

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