ShakeSession and shakeEnqueue (#554)

* ShakeSession and shakeRunGently

Currently we start a new Shake session for every interaction with the Shake
database, including type checking, hovers, code actions, completions, etc.
Since only one Shake session can ever exist, we abort the active session if any
in order to execute the new command in a responsive manner.

This is suboptimal in many, many ways:

- A hover in module M aborts the typechecking of module M, only to start over!
- Read-only commands (hover, code action, completion) need to typecheck all the
  modules! (or rather, ask Shake to check that the typechecks are current)
- There is no way to run non-interfering commands concurrently

This is an experiment inspired by the 'ShakeQueue' of @mpickering, and
the follow-up discussion in mpickering/ghcide#7

We introduce the concept of the 'ShakeSession' as part of the IDE state.
The 'ShakeSession' is initialized by a call to 'shakeRun', and survives until
the next call to 'shakeRun'. It is important that the session is restarted as
soon as the filesystem changes, to ensure that the database is current.

The 'ShakeSession' enables a new command 'shakeRunGently', which appends work to
the existing 'ShakeSession'. This command can be called in parallel without any
restriction.

* Simplify by assuming there is always a ShakeSession

* Improved naming and docs

* Define runActionSync on top of shakeEnqueue

shakeRun is not correct as it never returns anymore

* Drive progress reporting from newSession

The previous approach reused the shakeProgress thread,  which doesn't work anymore as ShakeSession keeps the ShakeDatabase open until the next edit

* Deterministic progress messages in tests

Dropping the 0.1s sleep to ensure that progress messages during tests are
deterministic

* Make kick explicit

This is required for progress reporting to work, see notes in shakeRun

As to whether this is the right thing to do:

1. Less magic, more explicit
2. There's only 2 places where kick is actually used

* apply Neil's feedback

* avoid a deadlock when the enqueued action throws

* Simplify runAction + comments

* use a Barrier for clarity

A Barrier is a smaller abstraction than an MVar, and the next version of the extra package will come with a suitably small implementation:

ndmitchell/extra@98c2a83

* Log timings for code actions, hovers and completions

* Rename shakeRun to shakeRestart

The action returned by shakeRun now blocks until another call to shakeRun is made, which is a change in behaviour,. but all the current uses of shakeRun ignore this action.

Since the new behaviour is not useful, this change simplifies and updates the docs and name accordingly

* delete runActionSync as it's just runAction

* restart shake session on new component created

* requeue pending actions on session restart

* hlint

* Bumped the delay from 5 to 6

* Add a test for the non-lsp command line

* Update exe/Main.hs

Co-authored-by: Moritz Kiefer <[email protected]>

Author: pepeiborra

exe/Main.hs

@@ -58,7 +58,7 @@ import System.Time.Extra
 import HIE.Bios.Environment (addCmdOpts, makeDynFlagsAbsolute)
 import Paths_ghcide
 import Development.GitRev
-import Development.Shake (Action, action)
+import Development.Shake (Action)
 import qualified Data.HashSet as HashSet
 import qualified Data.HashMap.Strict as HM
 import qualified Data.Map.Strict as Map
@@ -124,11 +124,11 @@ main = do
             let options = (defaultIdeOptions $ loadSessionShake dir)
                     { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
-                    , optTesting        = argsTesting
+                    , optTesting        = IdeTesting argsTesting
                     , optThreads        = argsThreads
                     }
             debouncer <- newAsyncDebouncer
-            initialise caps (mainRule >> pluginRules plugins >> action kick)
+            initialise caps (mainRule >> pluginRules plugins)
                 getLspId event (logger minBound) debouncer options vfs
     else do
         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
@@ -156,14 +156,14 @@ main = do
 
         putStrLn "\nStep 4/4: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
-        results <- runActionSync ide $ uses TypeCheck (map toNormalizedFilePath' files)
+        results <- runAction ide $ uses TypeCheck (map toNormalizedFilePath' files)
         let (worked, failed) = partition fst $ zip (map isJust results) files
         when (failed /= []) $
             putStr $ unlines $ "Files that failed:" : map ((++) " * " . snd) failed
 
         let files xs = let n = length xs in if n == 1 then "1 file" else show n ++ " files"
         putStrLn $ "\nCompleted (" ++ files worked ++ " worked, " ++ files failed ++ " failed)"
-        return ()
+        unless (null failed) (exitWith $ ExitFailure (length failed))
 
 expandFiles :: [FilePath] -> IO [FilePath]
 expandFiles = concatMapM $ \x -> do
@@ -177,12 +177,6 @@ expandFiles = concatMapM $ \x -> do
             fail $ "Couldn't find any .hs/.lhs files inside directory: " ++ x
         return files
 
-
-kick :: Action ()
-kick = do
-    files <- getFilesOfInterest
-    void $ uses TypeCheck $ HashSet.toList files
-
 -- | Print an LSP event.
 showEvent :: Lock -> FromServerMessage -> IO ()
 showEvent _ (EventFileDiagnostics _ []) = return ()
@@ -230,15 +224,15 @@ setNameCache nc hsc = hsc { hsc_NC = nc }
 loadSessionShake :: FilePath -> Action (FilePath -> Action (IdeResult HscEnvEq))
 loadSessionShake fp = do
   se <- getShakeExtras
-  IdeOptions{optTesting} <- getIdeOptions
-  res <- liftIO $ loadSession optTesting se fp
+  IdeOptions{optTesting = IdeTesting ideTesting} <- getIdeOptions
+  res <- liftIO $ loadSession ideTesting se fp
   return (fmap liftIO res)
 
 -- | This is the key function which implements multi-component support. All
 -- components mapping to the same hie.yaml file are mapped to the same
 -- HscEnv which is updated as new components are discovered.
 loadSession :: Bool -> ShakeExtras -> FilePath -> IO (FilePath -> IO (IdeResult HscEnvEq))
-loadSession optTesting ShakeExtras{logger, eventer} dir = do
+loadSession optTesting ShakeExtras{logger, eventer, restartShakeSession} dir = do
   -- Mapping from hie.yaml file to HscEnv, one per hie.yaml file
   hscEnvs <- newVar Map.empty :: IO (Var HieMap)
   -- Mapping from a Filepath to HscEnv
@@ -342,6 +336,9 @@ loadSession optTesting ShakeExtras{logger, eventer} dir = do
         modifyVar_ fileToFlags $ \var -> do
             pure $ Map.insert hieYaml (HM.fromList (cs ++ cached_targets)) var
 
+        -- Invalidate all the existing GhcSession build nodes by restarting the Shake session
+        restartShakeSession [kick]
+
         return (fst res)
 
   let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq)

src/Development/IDE/Core/FileStore.hs

@@ -30,6 +30,7 @@ import System.IO.Error
 import qualified Data.ByteString.Char8 as BS
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
+import Development.IDE.Core.OfInterest (kick)
 import qualified Data.Rope.UTF16 as Rope
 
 #ifdef mingw32_HOST_OS
@@ -174,7 +175,7 @@ setBufferModified state absFile contents = do
     VFSHandle{..} <- getIdeGlobalState state
     whenJust setVirtualFileContents $ \set ->
         set (filePathToUri' absFile) contents
-    void $ shakeRun state []
+    void $ shakeRestart state [kick]
 
 -- | 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
@@ -184,4 +185,4 @@ setSomethingModified state = do
     VFSHandle{..} <- getIdeGlobalState state
     when (isJust setVirtualFileContents) $
         fail "setSomethingModified can't be called on this type of VFSHandle"
-    void $ shakeRun state []
+    void $ shakeRestart state [kick]

src/Development/IDE/Core/OfInterest.hs

@@ -9,6 +9,7 @@
 module Development.IDE.Core.OfInterest(
     ofInterestRules,
     getFilesOfInterest, setFilesOfInterest, modifyFilesOfInterest,
+    kick
     ) where
 
 import Control.Concurrent.Extra
@@ -28,6 +29,7 @@ import Development.Shake
 
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
+import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Shake
 
 
@@ -79,4 +81,11 @@ 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 $ HashSet.toList files)
-    void $ shakeRun state []
+    void $ shakeRestart state [kick]
+
+-- | Typecheck all the files of interest.
+--   Could be improved
+kick :: Action ()
+kick = do
+    files <- getFilesOfInterest
+    void $ uses TypeCheck $ HashSet.toList files

src/Development/IDE/Core/Service.hs

@@ -11,15 +11,12 @@ module Development.IDE.Core.Service(
     getIdeOptions,
     IdeState, initialise, shutdown,
     runAction,
-    runActionSync,
     writeProfile,
     getDiagnostics, unsafeClearDiagnostics,
     ideLogger,
     updatePositionMapping,
     ) where
 
-import           Control.Concurrent.Extra
-import           Control.Concurrent.Async
 import Data.Maybe
 import Development.IDE.Types.Options (IdeOptions(..))
 import Control.Monad
@@ -29,7 +26,6 @@ import           Development.IDE.Core.FileExists (fileExistsRules)
 import           Development.IDE.Core.OfInterest
 import Development.IDE.Types.Logger
 import           Development.Shake
-import Data.Either.Extra
 import qualified Language.Haskell.LSP.Messages as LSP
 import qualified Language.Haskell.LSP.Types as LSP
 import qualified Language.Haskell.LSP.Types.Capabilities as LSP
@@ -62,6 +58,7 @@ initialise caps mainRule getLspId toDiags logger debouncer options vfs =
         debouncer
         (optShakeProfiling options)
         (optReportProgress options)
+        (optTesting options)
         shakeOptions
           { shakeThreads = optThreads options
           , shakeFiles   = fromMaybe "/dev/null" (optShakeFiles options)
@@ -83,23 +80,7 @@ shutdown = shakeShut
 -- available.  There might still be other rules running at this point,
 -- e.g., the ofInterestRule.
 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
-
-
--- | `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.
-runActionSync :: IdeState -> Action a -> IO a
-runActionSync s act = fmap head $ join $ shakeRun s [act]
+runAction ide action = join $ shakeEnqueue ide action
 
 getIdeOptions :: Action IdeOptions
 getIdeOptions = do