Soulomoon/mark dirty keys sync to hls graph direct cocurrent

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

@@ -614,9 +614,9 @@ readHieFileFromDisk recorder hie_loc = do
 -- | 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
+    (pm, hsc, foi) <- (,,) <$> use_ GetParsedModule file
+                           <*> (hscEnv <$> use_ GhcSessionDeps file)
+                           <*> use_ IsFileOfInterest file
     -- We should only call the typecheck rule for files of interest.
     -- Keeping typechecked modules in memory for other files is
     -- very expensive.

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)

hls-graph/src/Development/IDE/Graph/Internal/Action.hs

@@ -31,14 +31,15 @@ import           Development.IDE.Graph.Internal.Key
 import           Development.IDE.Graph.Internal.Rules    (RuleResult)
 import           Development.IDE.Graph.Internal.Types
 import           System.Exit
+import Data.IORef.Extra (atomicModifyIORef'_)
 
 type ShakeValue a = (Show a, Typeable a, Eq a, Hashable a, NFData a)
 
 -- | Always rerun this rule when dirty, regardless of the dependencies.
 alwaysRerun :: Action ()
 alwaysRerun = do
     ref <- Action $ asks actionDeps
-    liftIO $ modifyIORef' ref (AlwaysRerunDeps mempty <>)
+    liftIO $ atomicModifyIORef'_ ref (AlwaysRerunDeps mempty <>)
 
 parallel :: [Action a] -> Action [a]
 parallel [] = pure []
@@ -52,7 +53,7 @@ parallel xs = do
             liftIO $ mapConcurrently (ignoreState a) xs
         deps -> do
             (newDeps, res) <- liftIO $ unzip <$> mapConcurrently (usingState a) xs
-            liftIO $ writeIORef (actionDeps a) $ mconcat $ deps : newDeps
+            liftIO $ atomicWriteIORef (actionDeps a) $ mconcat $ deps : newDeps
             pure res
     where
         usingState a x = do
@@ -117,7 +118,8 @@ apply ks = do
     (is, vs) <- liftIO $ build db stack ks
     ref <- Action $ asks actionDeps
     let !ks = force $ fromListKeySet $ toList is
-    liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
+    -- liftIO $ modifyIORef' ref (ResultDeps [ks] <>)
+    liftIO $ atomicModifyIORef'_ ref (ResultDeps [ks]<>)
     pure vs
 
 -- | Evaluate a list of keys without recording any dependencies.

hls-graph/src/Development/IDE/Graph/Internal/Types.hs

@@ -21,13 +21,14 @@ import           Data.Maybe
 import           Data.Typeable
 import           Development.IDE.Graph.Classes
 import           Development.IDE.Graph.Internal.Key
-import           GHC.Conc                           (TVar, atomically)
+import           GHC.Conc                           (TVar, atomically, par)
 import           GHC.Generics                       (Generic)
 import qualified ListT
 import qualified StmContainers.Map                  as SMap
 import           StmContainers.Map                  (Map)
 import           System.Time.Extra                  (Seconds)
-import           UnliftIO                           (MonadUnliftIO)
+import           UnliftIO                           (MonadUnliftIO, concurrently)
+import Data.IORef.Extra (atomicModifyIORef'_)
 
 #if !MIN_VERSION_base(4,18,0)
 import           Control.Applicative                (liftA2)
@@ -67,7 +68,18 @@ data SRules = SRules {
 -- 'Development.IDE.Graph.Internal.Action.actionCatch'. In particular, it is
 -- permissible to use the 'MonadFail' instance, which will lead to an 'IOException'.
 newtype Action a = Action {fromAction :: ReaderT SAction IO a}
-    deriving newtype (Monad, Applicative, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
+    deriving newtype (Monad, Functor, MonadIO, MonadFail, MonadThrow, MonadCatch, MonadMask, MonadUnliftIO)
+
+instance Applicative Action where
+    pure a = Action $ pure a
+    (<*>) f x = Action $ do
+        (fn, xn) <- concurrently (fromAction f) (fromAction x)
+        -- fn <- fromAction f
+        -- xn <- fromAction x
+        -- merged last two actions
+        deps <- asks actionDeps
+        liftIO $ atomicModifyIORef'_ deps mergeLastTwo
+        return $ fn xn
 
 data SAction = SAction {
     actionDatabase :: !Database,
@@ -153,6 +165,12 @@ data Result = Result {
 data ResultDeps = UnknownDeps | AlwaysRerunDeps !KeySet | ResultDeps ![KeySet]
   deriving (Eq, Show)
 
+-- | mergeLastTwo is used to merge the last two ResultDeps in the list
+-- so applicative actions can be run in parallel.
+mergeLastTwo :: ResultDeps -> ResultDeps
+mergeLastTwo (ResultDeps (x:y:xs)) = ResultDeps $ (x <> y) : xs
+mergeLastTwo x = x
+
 getResultDepsDefault :: KeySet -> ResultDeps -> KeySet
 getResultDepsDefault _ (ResultDeps ids)      = fold ids
 getResultDepsDefault _ (AlwaysRerunDeps ids) = ids