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 https://github.com/mpickering/ghcide/issues/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:

98c2a83585

* 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 <moritz.kiefer@purelyfunctional.org>

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

src/Development/IDE/Core/Shake.hs

@@ -1,7 +1,9 @@
+{-# LANGUAGE RecursiveDo #-}
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE ConstraintKinds            #-}
 
@@ -23,7 +25,8 @@ module Development.IDE.Core.Shake(
     ShakeExtras(..), getShakeExtras, getShakeExtrasRules,
     IdeRule, IdeResult, GetModificationTime(..),
     shakeOpen, shakeShut,
-    shakeRun,
+    shakeRestart,
+    shakeEnqueue,
     shakeProfile,
     use, useWithStale, useNoFile, uses, usesWithStale,
     use_, useNoFile_, uses_,
@@ -69,8 +72,10 @@ import Development.IDE.Types.Location
 import Development.IDE.Types.Options
 import           Control.Concurrent.Async
 import           Control.Concurrent.Extra
-import           Control.Exception.Extra
+import           Control.Concurrent.STM.TQueue (flushTQueue, writeTQueue, readTQueue, newTQueue, TQueue)
+import           Control.Concurrent.STM (readTVar, writeTVar, newTVarIO, TVar, atomically)
 import           Control.DeepSeq
+import           Control.Exception.Extra
 import           System.Time.Extra
 import           Data.Typeable
 import qualified Language.Haskell.LSP.Messages as LSP
@@ -83,6 +88,7 @@ import           GHC.Generics
 import           System.IO.Unsafe
 import           Numeric.Extra
 import Language.Haskell.LSP.Types
+import Data.Foldable (traverse_)
 
 
 -- information we stash inside the shakeExtra field
@@ -104,6 +110,14 @@ data ShakeExtras = ShakeExtras
     -- accumlation of all previous mappings.
     ,inProgress :: Var (HMap.HashMap NormalizedFilePath Int)
     -- ^ How many rules are running for each file
+    ,getLspId :: IO LspId
+    -- ^ The generator for unique Lsp identifiers
+    ,reportProgress :: Bool
+    -- ^ Whether to send Progress messages to the client
+    ,ideTesting :: IdeTesting
+    -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
+    ,restartShakeSession :: [Action ()] -> IO ()
+    -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component
     }
 
 getShakeExtras :: Action ShakeExtras
@@ -222,13 +236,25 @@ type IdeRule k v =
   , NFData v
   )
 
+-- | A live Shake session with the ability to enqueue Actions for running.
+--   Keeps the 'ShakeDatabase' open, so at most one 'ShakeSession' per database.
+data ShakeSession = ShakeSession
+  { cancelShakeSession :: !(IO [Action ()])
+    -- ^ Closes the Shake session and returns the pending user actions
+  , runInShakeSession  :: !(forall a . Action a -> IO (IO a))
+    -- ^ Enqueue a user action in the Shake session.
+  }
+
+emptyShakeSession :: ShakeSession
+emptyShakeSession = ShakeSession (pure []) (\_ -> error "emptyShakeSession")
+
 -- | A Shake database plus persistent store. Can be thought of as storing
 --   mappings from @(FilePath, k)@ to @RuleResult k@.
 data IdeState = IdeState
-    {shakeDb :: ShakeDatabase
-    ,shakeAbort :: MVar (IO ()) -- close whoever was running last
-    ,shakeClose :: IO ()
-    ,shakeExtras :: ShakeExtras
+    {shakeDb         :: ShakeDatabase
+    ,shakeSession    :: MVar ShakeSession
+    ,shakeClose      :: IO ()
+    ,shakeExtras     :: ShakeExtras
     ,shakeProfileDir :: Maybe FilePath
     }
 
@@ -301,10 +327,11 @@ shakeOpen :: IO LSP.LspId
           -> Debouncer NormalizedUri
           -> Maybe FilePath
           -> IdeReportProgress
+          -> IdeTesting
           -> ShakeOptions
           -> Rules ()
           -> IO IdeState
-shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) opts rules = do
+shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress reportProgress) ideTesting opts rules = mdo
     inProgress <- newVar HMap.empty
     shakeExtras <- do
         globals <- newVar HMap.empty
@@ -313,25 +340,22 @@ shakeOpen getLspId eventer logger debouncer shakeProfileDir (IdeReportProgress r
         hiddenDiagnostics <- newVar mempty
         publishedDiagnostics <- newVar mempty
         positionMapping <- newVar HMap.empty
+        let restartShakeSession = shakeRestart ideState
         pure ShakeExtras{..}
-    (shakeDb, shakeClose) <-
+    (shakeDbM, shakeClose) <-
         shakeOpenDatabase
-            opts
-                { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts
-                -- we don't actually use the progress value, but Shake conveniently spawns/kills this thread whenever
-                -- we call into Shake, so abuse it for that purpose
-                , shakeProgress = const $ if reportProgress then lspShakeProgress getLspId eventer inProgress else pure ()
-                }
+            opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts }
             rules
-    shakeAbort <- newMVar $ return ()
-    shakeDb <- shakeDb
-    return IdeState{..}
+    shakeSession <- newMVar emptyShakeSession
+    shakeDb <- shakeDbM
+    let ideState = IdeState{..}
+    return ideState
 
-lspShakeProgress :: Hashable a => IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()
-lspShakeProgress getLspId sendMsg inProgress = do
+lspShakeProgress :: Hashable a => IdeTesting -> IO LSP.LspId -> (LSP.FromServerMessage -> IO ()) -> Var (HMap.HashMap a Int) -> IO ()
+lspShakeProgress (IdeTesting ideTesting) getLspId sendMsg inProgress = do
     -- first sleep a bit, so we only show progress messages if it's going to take
     -- a "noticable amount of time" (we often expect a thread kill to arrive before the sleep finishes)
-    sleep 0.1
+    unless ideTesting $ sleep 0.1
     lspId <- getLspId
     u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
     sendMsg $ LSP.ReqWorkDoneProgressCreate $ LSP.fmServerWorkDoneProgressCreateRequest
@@ -379,57 +403,126 @@ shakeProfile :: IdeState -> FilePath -> IO ()
 shakeProfile IdeState{..} = shakeProfileDatabase shakeDb
 
 shakeShut :: IdeState -> IO ()
-shakeShut IdeState{..} = withMVar shakeAbort $ \stop -> do
+shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do
     -- Shake gets unhappy if you try to close when there is a running
     -- request so we first abort that.
-    stop
+    void $ cancelShakeSession runner
     shakeClose
 
 -- | This is a variant of withMVar where the first argument is run unmasked and if it throws
 -- an exception, the previous value is restored while the second argument is executed masked.
-withMVar' :: MVar a -> (a -> IO ()) -> IO (a, c) -> IO c
+withMVar' :: MVar a -> (a -> IO b) -> (b -> IO (a, c)) -> IO c
 withMVar' var unmasked masked = mask $ \restore -> do
     a <- takeMVar var
-    restore (unmasked a) `onException` putMVar var a
-    (a', c) <- masked
+    b <- restore (unmasked a) `onException` putMVar var a
+    (a', c) <- masked b
     putMVar var a'
     pure c
 
--- | 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])
-shakeRun IdeState{shakeExtras=ShakeExtras{..}, ..} acts =
+-- | Restart the current 'ShakeSession' with the given system actions.
+--   Any computation running in the current session will be aborted,
+--   but user actions (added via 'shakeEnqueue') will be requeued.
+--   Progress is reported only on the system actions.
+shakeRestart :: IdeState -> [Action ()] -> IO ()
+shakeRestart it@IdeState{shakeExtras=ShakeExtras{logger}, ..} systemActs =
     withMVar'
-        shakeAbort
-        (\stop -> do
-              (stopTime,_) <- duration stop
-              logDebug logger $ T.pack $ "Starting shakeRun (aborting the previous one took " ++ showDuration stopTime ++ ")"
+        shakeSession
+        (\runner -> do
+              (stopTime,queue) <- duration (cancelShakeSession runner)
+              logDebug logger $ T.pack $ "Restarting build session (aborting the previous one took " ++ showDuration stopTime ++ ")"
+              return queue
         )
         -- It is crucial to be masked here, otherwise we can get killed
-        -- between spawning the new thread and updating shakeAbort.
+        -- between spawning the new thread and updating shakeSession.
         -- See https://github.com/digital-asset/ghcide/issues/79
-        (do
-              start <- offsetTime
-              aThread <- asyncWithUnmask $ \restore -> do
-                   res <- try (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb acts)
-                   runTime <- start
-                   let res' = case res of
-                            Left e -> "exception: " <> displayException e
-                            Right _ -> "completed"
-                       profile = case res of
-                            Right (_, Just fp) ->
-                                let link = case filePathToUri' $ toNormalizedFilePath' fp of
-                                                NormalizedUri _ x -> x
-                                in ", profile saved at " <> T.unpack link
-                            _ -> ""
-                   let logMsg = logDebug logger $ T.pack $
-                        "Finishing shakeRun (took " ++ showDuration runTime ++ ", " ++ res' ++ profile ++ ")"
-                   return (fst <$> res, logMsg)
-              let wrapUp (res, _) = do
-                    either (throwIO @SomeException) return res
-              _ <- async $ do
-                  (_, logMsg) <- wait aThread
-                  logMsg
-              pure (cancel aThread, wrapUp =<< wait aThread))
+        (fmap (,()) . newSession it systemActs)
+
+-- | Enqueue an action in the existing 'ShakeSession'.
+--   Returns a computation to block until the action is run, propagating exceptions.
+--   Assumes a 'ShakeSession' is available.
+--
+--   Appropriate for user actions other than edits.
+shakeEnqueue :: IdeState -> Action a -> IO (IO a)
+shakeEnqueue IdeState{shakeSession} act =
+    withMVar shakeSession $ \s -> runInShakeSession s act
+
+-- Set up a new 'ShakeSession' with a set of initial system and user actions
+-- Will crash if there is an existing 'ShakeSession' running.
+-- Progress is reported only on the system actions.
+-- Only user actions will get re-enqueued
+newSession :: IdeState -> [Action ()] -> [Action ()] -> IO ShakeSession
+newSession IdeState{shakeExtras=ShakeExtras{..}, ..} systemActs userActs = do
+    -- A work queue for actions added via 'runInShakeSession'
+    actionQueue :: TQueue (Action ()) <- atomically $ do
+        q <- newTQueue
+        traverse_ (writeTQueue q) userActs
+        return q
+    actionInProgress :: TVar (Maybe (Action())) <- newTVarIO Nothing
+
+    let
+        -- A daemon-like action used to inject additional work
+        -- Runs actions from the work queue sequentially
+        pumpAction =
+            forever $ do
+                join $ liftIO $ atomically $ do
+                    act <- readTQueue actionQueue
+                    writeTVar actionInProgress $ Just act
+                    return act
+                liftIO $ atomically $ writeTVar actionInProgress Nothing
+
+        progressRun
+          | reportProgress = lspShakeProgress ideTesting getLspId eventer inProgress
+          | otherwise = return ()
+
+        workRun restore = withAsync progressRun $ \progressThread -> do
+          let systemActs' =
+                [ [] <$ pumpAction
+                , parallel systemActs
+                    -- Only system actions are considered for progress reporting
+                    -- When done, cancel the progressThread to indicate completion
+                    <* liftIO (cancel progressThread)
+                ]
+          res <- try @SomeException
+                 (restore $ shakeRunDatabaseProfile shakeProfileDir shakeDb systemActs')
+          let res' = case res of
+                      Left e -> "exception: " <> displayException e
+                      Right _ -> "completed"
+              profile = case res of
+                      Right (_, Just fp) ->
+                          let link = case filePathToUri' $ toNormalizedFilePath' fp of
+                                          NormalizedUri _ x -> x
+                          in ", profile saved at " <> T.unpack link
+                      _ -> ""
+              -- Wrap up in a thread to avoid calling interruptible
+              -- operations inside the masked section
+          let wrapUp = logDebug logger $ T.pack $ "Finishing build session(" ++ res' ++ profile ++ ")"
+          return wrapUp
+
+    -- Do the work in a background thread
+    workThread <- asyncWithUnmask workRun
+
+    -- run the wrap up unmasked
+    _ <- async $ join $ wait workThread
+
+    -- 'runInShakeSession' is used to append work in this Shake session
+    --  The session stays open until 'cancelShakeSession' is called
+    let runInShakeSession :: forall a . Action a -> IO (IO a)
+        runInShakeSession act = do
+              res <- newBarrier
+              let act' = actionCatch @SomeException (Right <$> act) (pure . Left)
+              atomically $ writeTQueue actionQueue (act' >>= liftIO . signalBarrier res)
+              return (waitBarrier res >>= either throwIO return)
+
+    --  Cancelling is required to flush the Shake database when either
+    --  the filesystem or the Ghc configuration have changed
+        cancelShakeSession = do
+            cancel workThread
+            atomically $ do
+                q <- flushTQueue actionQueue
+                c <- readTVar actionInProgress
+                return (maybe [] pure c ++ q)
+
+    pure (ShakeSession{..})
 
 getDiagnostics :: IdeState -> IO [FileDiagnostic]
 getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do

src/Development/IDE/LSP/HoverDefinition.hs

@@ -22,6 +22,7 @@ import           Language.Haskell.LSP.Messages
 import           Language.Haskell.LSP.Types
 
 import qualified Data.Text as T
+import System.Time.Extra (showDuration, duration)
 
 gotoDefinition :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError LocationResponseParams)
 hover          :: IdeState -> TextDocumentPositionParams -> IO (Either ResponseError (Maybe Hover))
@@ -56,7 +57,8 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc
 logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b
 logAndRunRequest label getResults ide pos path = do
   let filePath = toNormalizedFilePath' path
-  logInfo (ideLogger ide) $
+  (t, res) <- duration $ runAction ide $ getResults filePath pos
+  logDebug (ideLogger ide) $
     label <> " request at position " <> T.pack (showPosition pos) <>
-    " in file: " <> T.pack path
-  runAction ide $ getResults filePath pos
+    " in file: " <> T.pack path <> " took " <> T.pack (showDuration t)
+  return res

src/Development/IDE/Plugin/CodeAction.hs

@@ -32,6 +32,7 @@ import Development.IDE.Plugin.CodeAction.PositionIndexed
 import Development.IDE.Plugin.CodeAction.RuleTypes
 import Development.IDE.Plugin.CodeAction.Rules
 import Development.IDE.Types.Location
+import Development.IDE.Types.Logger
 import Development.IDE.Types.Options
 import Development.Shake (Rules)
 import qualified Data.HashMap.Strict as Map
@@ -53,6 +54,7 @@ import Text.Regex.TDFA.Text()
 import Outputable (ppr, showSDocUnsafe)
 import DynFlags (xFlags, FlagSpec(..))
 import GHC.LanguageExtensions.Type (Extension)
+import System.Time.Extra (showDuration, duration)
 
 plugin :: Plugin c
 plugin = codeActionPluginWithRules rules codeAction <> Plugin mempty setHandlersCodeLens
@@ -69,22 +71,31 @@ codeAction
     -> CodeActionContext
     -> IO (Either ResponseError [CAResult])
 codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
-    -- disable logging as its quite verbose
-    -- logInfo (ideLogger ide) $ T.pack $ "Code action req: " ++ show arg
     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
-    let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
-        mbFile = toNormalizedFilePath' <$> uriToFilePath uri
-    (ideOptions, parsedModule, join -> env) <- runAction state $
-      (,,) <$> getIdeOptions
-            <*> getParsedModule `traverse` mbFile
-            <*> use GhcSession `traverse` mbFile
-    pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env
-    let dflags = hsc_dflags . hscEnv <$> env
-    pure $ Right
-        [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
-        | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x
-        , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
-        ]
+    let fp = uriToFilePath uri
+        text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
+        mbFile = toNormalizedFilePath' <$> fp
+    logAndRunRequest state fp $ do
+      (ideOptions, parsedModule, join -> env) <- runAction state $
+        (,,) <$> getIdeOptions
+              <*> getParsedModule `traverse` mbFile
+              <*> use GhcSession `traverse` mbFile
+      pkgExports <- runAction state $ (useNoFile_ . PackageExports) `traverse` env
+      let dflags = hsc_dflags . hscEnv <$> env
+      pure $ Right
+          [ CACodeAction $ CodeAction title (Just CodeActionQuickFix) (Just $ List [x]) (Just edit) Nothing
+          | x <- xs, (title, tedit) <- suggestAction dflags (fromMaybe mempty pkgExports) ideOptions ( join parsedModule ) text x
+          , let edit = WorkspaceEdit (Just $ Map.singleton uri $ List tedit) Nothing
+          ]
+
+logAndRunRequest :: IdeState -> Maybe FilePath -> IO a -> IO a
+logAndRunRequest _de Nothing act = act
+logAndRunRequest ide (Just filepath) act = do
+    (t, res) <- duration act
+    logDebug (ideLogger ide) $
+        "code action request in file: " <> T.pack filepath <>
+        " took " <> T.pack (showDuration t)
+    return res
 
 -- | Generate code lenses.
 codeLens

src/Development/IDE/Plugin/Completions.hs

@@ -18,11 +18,14 @@ import Development.IDE.Plugin
 import Development.IDE.Core.Service
 import Development.IDE.Plugin.Completions.Logic
 import Development.IDE.Types.Location
+import Development.IDE.Types.Logger
 import Development.IDE.Core.PositionMapping
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Shake
 import Development.IDE.GHC.Util
 import Development.IDE.LSP.Server
+import System.Time.Extra (showDuration, duration)
+import Data.Text (pack)
 
 #if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)
 import Data.Maybe
@@ -76,7 +79,7 @@ getCompletionsLSP lsp ide
                   ,_context=completionContext} = do
     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
     fmap Right $ case (contents, uriToFilePath' uri) of
-      (Just cnts, Just path) -> do
+      (Just cnts, Just path) -> logAndRunRequest ide path $ do
         let npath = toNormalizedFilePath' path
         (ideOpts, compls) <- runAction ide $ do
             opts <- getIdeOptions
@@ -97,6 +100,14 @@ getCompletionsLSP lsp ide
           _ -> return (Completions $ List [])
       _ -> return (Completions $ List [])
 
+logAndRunRequest :: IdeState -> FilePath -> IO a -> IO a
+logAndRunRequest ide filepath act = do
+    (t, res) <- duration act
+    logDebug (ideLogger ide) $
+        "completion request in file: " <> pack filepath <>
+        " took " <> pack (showDuration t)
+    return res
+
 setHandlersCompletion :: PartialHandlers c
 setHandlersCompletion = PartialHandlers $ \WithMessage{..} x -> return x{
     LSP.completionHandler = withResponse RspCompletion getCompletionsLSP

src/Development/IDE/Types/Options.hs

@@ -9,6 +9,7 @@ module Development.IDE.Types.Options
   , IdePreprocessedSource(..)
   , IdeReportProgress(..)
   , IdeDefer(..)
+  , IdeTesting(..)
   , clientSupportsProgress
   , IdePkgLocationOptions(..)
   , defaultIdeOptions
@@ -43,7 +44,7 @@ data IdeOptions = IdeOptions
   -- meaning we keep everything in memory but the daml CLI compiler uses this for incremental builds.
   , optShakeProfiling :: Maybe FilePath
     -- ^ Set to 'Just' to create a directory of profiling reports.
-  , optTesting :: Bool
+  , optTesting :: IdeTesting
     -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
   , optReportProgress :: IdeReportProgress
     -- ^ Whether to report progress during long operations.
@@ -73,6 +74,7 @@ data IdePreprocessedSource = IdePreprocessedSource
 
 newtype IdeReportProgress = IdeReportProgress Bool
 newtype IdeDefer          = IdeDefer          Bool
+newtype IdeTesting        = IdeTesting        Bool
 
 clientSupportsProgress :: LSP.ClientCapabilities -> IdeReportProgress
 clientSupportsProgress caps = IdeReportProgress $ Just True ==
@@ -92,7 +94,7 @@ defaultIdeOptions session = IdeOptions
     ,optNewColonConvention = False
     ,optKeywords = haskellKeywords
     ,optDefer = IdeDefer True
-    ,optTesting = False
+    ,optTesting = IdeTesting False
     }
 
 

test/exe/Main.hs

@@ -39,6 +39,8 @@ import System.Environment.Blank (getEnv, setEnv, unsetEnv)
 import System.FilePath
 import System.IO.Extra
 import System.Directory
+import System.Exit (ExitCode(ExitSuccess))
+import System.Process.Extra (readCreateProcessWithExitCode, CreateProcess(cwd), proc)
 import Test.QuickCheck
 import Test.QuickCheck.Instances ()
 import Test.Tasty
@@ -77,6 +79,7 @@ main = do
     , watchedFilesTests
     , cradleTests
     , dependentFileTest
+    , nonLspCommandLine
     ]
 
 initializeResponseTests :: TestTree
@@ -2147,7 +2150,7 @@ simpleMultiTest2 = testCase "simple-multi-test2" $ withoutStackEnv $ runWithExtr
     aSource <- liftIO $ readFileUtf8 aPath
     (TextDocumentIdentifier adoc) <- createDoc aPath "haskell" aSource
     -- Need to have some delay here or the test fails
-    expectNoMoreDiagnostics 5
+    expectNoMoreDiagnostics 6
     locs <- getDefinitions bdoc (Position 2 7)
     let fooL = mkL adoc 2 0 2 3
     checkDefs locs (pure [fooL])
@@ -2189,6 +2192,20 @@ sessionDepsArePickedUp = testSession'
           "foo = \"hello\""
         ]
 
+-- A test to ensure that the command line ghcide workflow stays working
+nonLspCommandLine :: TestTree
+nonLspCommandLine = testGroup "ghcide command line"
+  [ testCase "works" $ withTempDir $ \dir -> do
+        ghcide <- locateGhcideExecutable
+        copyTestDataFiles dir "multi"
+        let cmd = (proc ghcide ["a/A.hs"]){cwd = Just dir}
+
+        setEnv "HOME" "/homeless-shelter" False
+
+        (ec, _, _) <- withoutStackEnv $ readCreateProcessWithExitCode cmd ""
+
+        ec @=? ExitSuccess
+  ]
 
 ----------------------------------------------------------------------
 -- Utils