Avoid non-termination in runAction (#1938)

* Add more comments to shakeRun

* Delete the multiple versions of runActions, since they weren't used and parallel is good enough

* Delete runActionsSync entirely

* Make sure runAction returns even if shakeRun throws an exception

* Remove the callback from shakeRun - it was never used

* Fix one last use

* More comments

compiler/hie-core/src/Development/IDE/Core/FileStore.hs

@@ -167,7 +167,7 @@ setBufferModified state absFile contents = do
     VFSHandle{..} <- getIdeGlobalState state
     whenJust setVirtualFileContents $ \set ->
         set (filePathToUri' absFile) contents
-    void $ shakeRun state [] (const $ pure ())
+    void $ shakeRun state []
 
 -- | Note that some buffer somewhere has been modified, but don't say what.
 --   Only valid if the virtual file system was initialised by LSP, as that
@@ -177,4 +177,4 @@ setSomethingModified state = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setSomethingModified can't be called on this type of VFSHandle"
-    void $ shakeRun state [] (const $ pure ())
+    void $ shakeRun state []

compiler/hie-core/src/Development/IDE/Core/OfInterest.hs

@@ -78,4 +78,4 @@ modifyFilesOfInterest state f = do
     OfInterestVar var <- getIdeGlobalState state
     files <- modifyVar var $ pure . dupe . f
     logDebug (ideLogger state) $ "Set files of interest to: " <> T.pack (show $ Set.toList files)
-    void $ shakeRun state [] (const $ pure ())
+    void $ shakeRun state []

compiler/hie-core/src/Development/IDE/Core/Rules.hs

@@ -12,7 +12,7 @@
 module Development.IDE.Core.Rules(
     IdeState, GetDependencies(..), GetParsedModule(..), TransitiveDependencies(..),
     Priority(..),
-    runAction, runActions, useE, usesE,
+    runAction, useE, usesE,
     toIdeResult, defineNoFile,
     mainRule,
     getGhcCore,

compiler/hie-core/src/Development/IDE/Core/Service.hs

@@ -11,20 +11,22 @@
 module Development.IDE.Core.Service(
     getIdeOptions,
     IdeState, initialise, shutdown,
-    runAction, runActions,
-    runActionSync, runActionsSync,
+    runAction,
+    runActionSync,
     writeProfile,
     getDiagnostics, unsafeClearDiagnostics,
     ideLogger
     ) where
 
 import           Control.Concurrent.Extra
+import           Control.Concurrent.Async
 import           Control.Monad.Except
 import Development.IDE.Types.Options (IdeOptions(..))
 import           Development.IDE.Core.FileStore
 import           Development.IDE.Core.OfInterest
 import Development.IDE.Types.Logger
 import           Development.Shake                        hiding (Diagnostic, Env, newCache)
+import Data.Either.Extra
 import qualified Language.Haskell.LSP.Messages as LSP
 
 import           Development.IDE.Core.Shake
@@ -68,32 +70,27 @@ setProfiling opts shakeOpts =
 shutdown :: IdeState -> IO ()
 shutdown = shakeShut
 
--- | Run a single action using the supplied service. See `runActions`
--- for more details.
-runAction :: IdeState -> Action a -> IO a
-runAction service action = head <$> runActions service [action]
-
--- | Run a list of actions in parallel using the supplied service.
--- This will return as soon as the results of the actions are
+-- This will return as soon as the result of the action is
 -- available.  There might still be other rules running at this point,
 -- e.g., the ofInterestRule.
-runActions :: IdeState -> [Action a] -> IO [a]
-runActions x acts = do
-    var <- newBarrier
-    _ <- shakeRun x acts (signalBarrier var)
-    waitBarrier var
+runAction :: IdeState -> Action a -> IO a
+runAction ide action = do
+    bar <- newBarrier
+    res <- shakeRun ide [do v <- action; liftIO $ signalBarrier bar v; return v]
+    -- shakeRun might throw an exception (either through action or a default rule),
+    -- in which case action may not complete successfully, and signalBarrier might not be called.
+    -- Therefore we wait for either res (which propagates the exception) or the barrier.
+    -- Importantly, if the barrier does finish, cancelling res only kills waiting for the result,
+    -- it doesn't kill the actual work
+    fmap fromEither $ race (head <$> res) $ waitBarrier bar
 
--- | This is a synchronous variant of `runAction`. See
--- `runActionsSync` of more details.
-runActionSync :: IdeState -> Action a -> IO a
-runActionSync s a = head <$> runActionsSync s [a]
 
--- | `runActionsSync` is similar to `runActions` but it will
+-- | `runActionSync` is similar to `runAction` but it will
 -- wait for all rules (so in particular the `ofInterestRule`) to
 -- finish running. This is mainly useful in tests, where you want
 -- to wait for all rules to fire so you can check diagnostics.
-runActionsSync :: IdeState -> [Action a] -> IO [a]
-runActionsSync s acts = join $ shakeRun s acts (const $ pure ())
+runActionSync :: IdeState -> Action a -> IO a
+runActionSync s act = fmap head $ join $ shakeRun s [act]
 
 getIdeOptions :: Action IdeOptions
 getIdeOptions = do

compiler/hie-core/src/Development/IDE/Core/Shake.hs

@@ -237,25 +237,17 @@ shakeShut IdeState{..} = withVar shakeAbort $ \stop -> do
     stop
     shakeClose
 
--- | Spawn immediately, add an action to collect the results syncronously.
---   If you are already inside a call to shakeRun that will be aborted with an exception.
--- The callback will be fired as soon as the results are available
--- even if there are still other rules running while the IO action that is
--- being returned will wait for all rules to finish.
-shakeRun :: IdeState -> [Action a] -> ([a] -> IO ()) -> IO (IO [a])
+-- | Spawn immediately. If you are already inside a call to shakeRun that will be aborted with an exception.
+shakeRun :: IdeState -> [Action a] -> IO (IO [a])
 -- FIXME: If there is already a shakeRun queued up and waiting to send me a kill, I should probably
 --        not even start, which would make issues with async exceptions less problematic.
-shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts callback = modifyVar shakeAbort $ \stop -> do
+shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts = modifyVar shakeAbort $ \stop -> do
     (stopTime,_) <- duration stop
     logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
     bar <- newBarrier
     start <- offsetTime
-    let act = do
-            res <- parallel acts
-            liftIO $ callback res
-            pure res
-    thread <- forkFinally (shakeRunDatabaseProfile shakeDb [act]) $ \res -> do
-        signalBarrier bar (mapRight head res)
+    thread <- forkFinally (shakeRunDatabaseProfile shakeDb acts) $ \res -> do
+        signalBarrier bar res
         runTime <- start
         logDebug logger $ T.pack $
             "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ (if isLeft res then "exception" else "completed") ++ ")"

daml-foundations/daml-ghc/ide/src/Development/IDE/State/API.hs

@@ -15,9 +15,7 @@ module Development.IDE.State.API
     , modifyOpenVirtualResources
     , setBufferModified
     , runAction
-    , runActions
     , runActionSync
-    , runActionsSync
     , writeProfile
     , getDiagnostics
     , unsafeClearDiagnostics

daml-foundations/daml-ghc/ide/src/Development/IDE/State/Service/Daml.hs

@@ -7,8 +7,8 @@ module Development.IDE.Core.Service.Daml(
     DamlEnv(..),
     getDamlServiceEnv,
     IdeState, initialise, shutdown,
-    runAction, runActions,
-    runActionSync, runActionsSync,
+    runAction,
+    runActionSync,
     setFilesOfInterest, modifyFilesOfInterest, setOpenVirtualResources, modifyOpenVirtualResources,
     writeProfile,
     getDiagnostics, unsafeClearDiagnostics,
@@ -95,7 +95,7 @@ modifyOpenVirtualResources state f = do
     DamlEnv{..} <- getIdeGlobalState state
     vrs <- modifyVar envOpenVirtualResources $ pure . dupe . f
     logDebug (ideLogger state) $ "Set vrs of interest to: " <> T.pack (show $ Set.toList vrs)
-    void $ shakeRun state [] (const $ pure ())
+    void $ shakeRun state []
 
 initialise
     :: Rules ()

daml-foundations/daml-ghc/ide/test/Development/IDE/State/API/Testing.hs

@@ -213,7 +213,7 @@ getDiagnostics :: ShakeTest [D.FileDiagnostic]
 getDiagnostics = ShakeTest $ do
     service <- Reader.asks steService
     liftIO $ do
-        void $ API.runActionsSync service []
+        void $ API.runActionSync service $ return ()
         API.getDiagnostics service
 
 -- | Everything that rebuilt in the last execution must pass the predicate
@@ -223,7 +223,7 @@ expectLastRebuilt predicate = ShakeTest $ do
     testDir <- Reader.asks steTestDirPath
     liftIO $ withTempDir $ \dir -> do
         let file = dir </> "temp.json"
-        void $ API.runActionsSync service []
+        void $ API.runActionSync service $ return ()
         API.writeProfile service file
         rebuilt <- either error (return . parseShakeProfileJSON testDir) =<< Aeson.eitherDecodeFileStrict' file
         -- ignore those which are set to alwaysRerun - not interesting
@@ -263,7 +263,7 @@ getVirtualResources = ShakeTest $ do
     service <- Reader.asks steService
     virtualResources <- Reader.asks steVirtualResources
     liftIO $ do
-      void $ API.runActionsSync service []
+      void $ API.runActionSync service $ return ()
       readTVarIO virtualResources
 
 -- | Convenient grouping of file path, 0-based line number, 0-based column number.