actionFork

Author: pepeiborra

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

@@ -658,7 +658,7 @@ newSession extras@ShakeExtras{..} shakeDb acts = do
         -- Runs actions from the work queue sequentially
         pumpActionThread otSpan = do
             d <- liftIO $ atomically $ popQueue actionQueue
-            void $ parallel [run otSpan d, pumpActionThread otSpan]
+            actionFork (run otSpan d) $ \_ -> pumpActionThread otSpan
 
         -- TODO figure out how to thread the otSpan into defineEarlyCutoff
         run _otSpan d  = do

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

@@ -5,7 +5,7 @@ module Development.IDE.Graph(
     Rules,
     Action, action,
     Key(..),
-    actionFinally, actionBracket, actionCatch,
+    actionFinally, actionBracket, actionCatch, actionFork,
     Shake.ShakeException(..),
     -- * Configuration
     ShakeOptions(shakeAllowRedefineRules, shakeThreads, shakeFiles, shakeExtra),

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

@@ -2,7 +2,18 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
 
-module Development.IDE.Graph.Internal.Action where
+module Development.IDE.Graph.Internal.Action
+( actionFork
+, actionBracket
+, actionCatch
+, actionFinally
+, alwaysRerun
+, apply1
+, apply
+, parallel
+, reschedule
+, runActions
+) where
 
 import           Control.Concurrent.Async
 import           Control.Exception
@@ -42,16 +53,30 @@ parallel xs = do
             liftIO $ writeIORef (actionDeps a) $ (deps ++) <$> concatMapM id newDeps
             pure res
     where
-        ignoreState a x = do
-            ref <- newIORef Nothing
-            runReaderT (fromAction x) a{actionDeps=ref}
-
         usingState a x = do
             ref <- newIORef $ Just []
             res <- runReaderT (fromAction x) a{actionDeps=ref}
             deps <- readIORef ref
             pure (deps, res)
 
+ignoreState :: SAction -> Action b -> IO b
+ignoreState a x = do
+    ref <- newIORef Nothing
+    runReaderT (fromAction x) a{actionDeps=ref}
+
+actionFork :: Action a -> (Async a -> Action b) -> Action b
+actionFork act k = do
+    a <- Action ask
+    deps <- liftIO $ readIORef $ actionDeps a
+    let db = actionDatabase a
+    case deps of
+        Nothing -> do
+            -- if we are already in the rerun mode, nothing we do is going to impact our state
+            [res] <- liftIO $ withAsync (ignoreState a act) $ \as -> runActions db [k as]
+            return res
+        _ ->
+            error "please help me"
+
 isAsyncException :: SomeException -> Bool
 isAsyncException e
     | Just (_ :: AsyncCancelled) <- fromException e = True