Use stale information if it's available to answer requests quickly (#624)

* Use stale information for hover and completions

This introduces a new function `useWithStaleFast` which returns with
stale information WITHOUT checking freshness like `use` and
`useWithStale`.

Greatly improve debug logging

All actions triggered by shakeRun now also pass an identifier which
means that the debug logging shows which actions are starting/finishing

We also distinguish between internal and external events. By default
external events are ones triggered by runAction and the debug output
is displayed to the user in command line and --lsp mode.

In order to see internal logging statements, there is a new flag called
--verbose which also prints out internal events such as file
modification flushes.

Cleaner variant using runAfter

Step 1: Do not run actions with shakeRun

Queue implementation, living, breathing

Use a priority queue to schedule shake actions.

Most user actions are answered immediately with a cache but also
spawn a shake action to check the cached value we consulted was up to
date.

* Remove DelayedActionExtra

* hlint

* Fix progress

* Always block instead of fail on initial computation

* Can block for code lens

* Update docs

Co-authored-by: Zubin Duggal <zubin@cmi.ac.in>

cabal.project

@@ -0,0 +1 @@
+packages: .

exe/Arguments.hs

@@ -14,6 +14,7 @@ data Arguments = Arguments
     ,argsShakeProfiling :: Maybe FilePath
     ,argsTesting :: Bool
     ,argsThreads :: Int
+    ,argsVerbose :: Bool
     }
 
 getArguments :: IO Arguments
@@ -33,3 +34,4 @@ arguments = Arguments
       <*> optional (strOption $ long "shake-profiling" <> metavar "DIR" <> help "Dump profiling reports to this directory")
       <*> switch (long "test" <> help "Enable additional lsp messages used by the testsuite")
       <*> option auto (short 'j' <> help "Number of threads (0: automatic)" <> metavar "NUM" <> value 0 <> showDefault)
+      <*> switch (long "verbose" <> help "Include internal events in logging output")

exe/Main.hs

@@ -130,9 +130,10 @@ main = do
                     , optTesting        = IdeTesting argsTesting
                     , optThreads        = argsThreads
                     }
+                logLevel = if argsVerbose then minBound else Info
             debouncer <- newAsyncDebouncer
             initialise caps (mainRule >> pluginRules plugins)
-                getLspId event wProg wIndefProg (logger minBound) debouncer options vfs
+                getLspId event wProg wIndefProg (logger logLevel) debouncer options vfs
     else do
         -- GHC produces messages with UTF8 in them, so make sure the terminal doesn't error
         hSetEncoding stdout utf8
@@ -161,7 +162,7 @@ main = do
 
         putStrLn "\nStep 4/4: Type checking the files"
         setFilesOfInterest ide $ HashSet.fromList $ map toNormalizedFilePath' files
-        results <- runAction ide $ uses TypeCheck (map toNormalizedFilePath' files)
+        results <- runAction "User TypeCheck" 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

src/Development/IDE/Core/FileStore.hs

@@ -7,6 +7,7 @@ module Development.IDE.Core.FileStore(
     getFileContents,
     getVirtualFile,
     setBufferModified,
+    setFileModified,
     setSomethingModified,
     fileStoreRules,
     VFSHandle,
@@ -31,6 +32,7 @@ import qualified Data.ByteString.Char8 as BS
 import Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.Core.OfInterest (kick)
+import Development.IDE.Core.RuleTypes
 import qualified Data.Rope.UTF16 as Rope
 
 #ifdef mingw32_HOST_OS
@@ -45,6 +47,8 @@ import Foreign.Storable
 import qualified System.Posix.Error as Posix
 #endif
 
+import qualified Development.IDE.Types.Logger as L
+
 import Language.Haskell.LSP.Core
 import Language.Haskell.LSP.VFS
 
@@ -180,6 +184,20 @@ setBufferModified state absFile contents = do
         set (filePathToUri' absFile) contents
     void $ shakeRestart state [kick]
 
+-- | Note that some buffer for a specific file has been modified but not
+-- with what changes.
+setFileModified :: IdeState -> NormalizedFilePath -> IO ()
+setFileModified state nfp = do
+    VFSHandle{..} <- getIdeGlobalState state
+    when (isJust setVirtualFileContents) $
+        fail "setSomethingModified can't be called on this type of VFSHandle"
+    let da = mkDelayedAction "FileStoreTC" L.Info $ do
+          ShakeExtras{progressUpdate} <- getShakeExtras
+          liftIO $ progressUpdate KickStarted
+          void $ use GetSpanInfo nfp
+          liftIO $ progressUpdate KickCompleted
+    shakeRestart state [da]
+
 -- | 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
 --   independently tracks which files are modified.

src/Development/IDE/Core/OfInterest.hs

@@ -24,14 +24,13 @@ import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import qualified Data.Text as T
 import Data.Tuple.Extra
-import Data.Functor
 import Development.Shake
 
 import Development.IDE.Types.Location
 import Development.IDE.Types.Logger
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Shake
-
+import Control.Monad
 
 newtype OfInterestVar = OfInterestVar (Var (HashSet NormalizedFilePath))
 instance IsIdeGlobal OfInterestVar
@@ -81,12 +80,13 @@ 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 $ shakeRestart state [kick]
+    let das = map (\nfp -> mkDelayedAction "OfInterest" Debug (use GetSpanInfo nfp)) (HashSet.toList files)
+    shakeRestart state das
 
 -- | Typecheck all the files of interest.
 --   Could be improved
-kick :: Action ()
-kick = do
+kick :: DelayedAction ()
+kick = mkDelayedAction "kick" Debug $ do
     files <- getFilesOfInterest
     ShakeExtras{progressUpdate} <- getShakeExtras
     liftIO $ progressUpdate KickStarted

src/Development/IDE/Core/Rules.hs

@@ -50,6 +50,7 @@ import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
 import Development.IDE.GHC.Util
 import Development.IDE.GHC.WithDynFlags
 import Data.Either.Extra
+import qualified Development.IDE.Types.Logger as L
 import Data.Maybe
 import           Data.Foldable
 import qualified Data.IntMap.Strict as IntMap
@@ -62,6 +63,7 @@ import           Development.Shake                        hiding (Diagnostic)
 import Development.IDE.Core.RuleTypes
 import Development.IDE.Spans.Type
 import qualified Data.ByteString.Char8 as BS
+import Development.IDE.Core.PositionMapping
 
 import qualified GHC.LanguageExtensions as LangExt
 import HscTypes
@@ -76,10 +78,12 @@ import Development.Shake.Classes hiding (get, put)
 import Control.Monad.Trans.Except (runExceptT)
 import Data.ByteString (ByteString)
 import Control.Concurrent.Async (concurrently)
+import System.Time.Extra
+import Control.Monad.Reader
+import System.Directory ( getModificationTime )
+import Control.Exception
 
 import Control.Monad.State
-import System.IO.Error (isDoesNotExistError)
-import Control.Exception.Safe (IOException, catch)
 import FastString (FastString(uniq))
 import qualified HeaderInfo as Hdr
 
@@ -91,14 +95,14 @@ toIdeResult = either (, Nothing) (([],) . Just)
 
 -- | useE is useful to implement functions that aren’t rules but need shortcircuiting
 -- e.g. getDefinition.
-useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT Action v
-useE k = MaybeT . use k
+useE :: IdeRule k v => k -> NormalizedFilePath -> MaybeT IdeAction (v, PositionMapping)
+useE k = MaybeT . useWithStaleFast k
 
-useNoFileE :: IdeRule k v => k -> MaybeT Action v
-useNoFileE k = useE k emptyFilePath
+useNoFileE :: IdeRule k v => IdeState -> k -> MaybeT IdeAction v
+useNoFileE _ide k = fst <$> useE k emptyFilePath
 
-usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT Action [v]
-usesE k = MaybeT . fmap sequence . uses k
+usesE :: IdeRule k v => k -> [NormalizedFilePath] -> MaybeT IdeAction [(v,PositionMapping)]
+usesE k = MaybeT . fmap sequence . mapM (useWithStaleFast k)
 
 defineNoFile :: IdeRule k v => (k -> Action v) -> Rules ()
 defineNoFile f = define $ \k file -> do
@@ -120,65 +124,78 @@ getDependencies :: NormalizedFilePath -> Action (Maybe [NormalizedFilePath])
 getDependencies file = fmap transitiveModuleDeps <$> use GetDependencies file
 
 -- | Try to get hover text for the name under point.
-getAtPoint :: NormalizedFilePath -> Position -> Action (Maybe (Maybe Range, [T.Text]))
+getAtPoint :: NormalizedFilePath -> Position -> IdeAction (Maybe (Maybe Range, [T.Text]))
 getAtPoint file pos = fmap join $ runMaybeT $ do
-  opts <- lift getIdeOptions
-  spans <- useE GetSpanInfo file
-  return $ AtPoint.atPoint opts spans pos
+  ide <- ask
+  opts <- liftIO $ getIdeOptionsIO ide
+  (spans, mapping) <- useE  GetSpanInfo file
+  !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
+  return $ AtPoint.atPoint opts spans pos'
 
 -- | Goto Definition.
-getDefinition :: NormalizedFilePath -> Position -> Action (Maybe Location)
-getDefinition file pos = fmap join $ runMaybeT $ do
-    opts <- lift getIdeOptions
-    spans <- useE GetSpanInfo file
-    lift $ AtPoint.gotoDefinition (getHieFile file) opts (spansExprs spans) pos
+getDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe Location)
+getDefinition file pos = runMaybeT $ do
+    ide <- ask
+    opts <- liftIO $ getIdeOptionsIO ide
+    (spans,mapping) <- useE GetSpanInfo file
+    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
+    AtPoint.gotoDefinition (getHieFile ide file) opts (spansExprs spans) pos'
 
-getTypeDefinition :: NormalizedFilePath -> Position -> Action (Maybe [Location])
+getTypeDefinition :: NormalizedFilePath -> Position -> IdeAction (Maybe [Location])
 getTypeDefinition file pos = runMaybeT $ do
-    opts <- lift getIdeOptions
-    spans <- useE GetSpanInfo file
-    lift $ AtPoint.gotoTypeDefinition (getHieFile file) opts (spansExprs spans) pos
-
+    ide <- ask
+    opts <- liftIO $ getIdeOptionsIO ide
+    (spans,mapping) <- useE GetSpanInfo file
+    !pos' <- MaybeT (return $ fromCurrentPosition mapping pos)
+    AtPoint.gotoTypeDefinition (getHieFile ide file) opts (spansExprs spans) pos'
 
 getHieFile
-  :: NormalizedFilePath -- ^ file we're editing
+  :: ShakeExtras
+  -> NormalizedFilePath -- ^ file we're editing
   -> Module -- ^ module dep we want info for
-  -> Action (Maybe (HieFile, FilePath)) -- ^ hie stuff for the module
-getHieFile file mod = do
-  TransitiveDependencies {transitiveNamedModuleDeps} <- use_ GetDependencies file
+  -> MaybeT IdeAction (HieFile, FilePath) -- ^ hie stuff for the module
+getHieFile ide file mod = do
+  TransitiveDependencies {transitiveNamedModuleDeps} <- fst <$> useE GetDependencies file
   case find (\x -> nmdModuleName x == moduleName mod) transitiveNamedModuleDeps of
     Just NamedModuleDep{nmdFilePath=nfp} -> do
         let modPath = fromNormalizedFilePath nfp
-        (_diags, hieFile) <- getHomeHieFile nfp
-        return $ (, modPath) <$> hieFile
-    _ -> getPackageHieFile mod file
+        hieFile <- getHomeHieFile nfp
+        return (hieFile, modPath)
+    _ -> getPackageHieFile ide mod file
 
-
-getHomeHieFile :: NormalizedFilePath -> Action ([IOException], Maybe HieFile)
+getHomeHieFile :: NormalizedFilePath -> MaybeT IdeAction HieFile
 getHomeHieFile f = do
-  ms <- use_ GetModSummary f
+  ms <- fst <$> useE GetModSummary f
+  let normal_hie_f = toNormalizedFilePath' hie_f
+      hie_f = ml_hie_file $ ms_location ms
 
-  -- .hi and .hie files are generated as a byproduct of typechecking.
-  -- To avoid duplicating staleness checking already performed for .hi files,
-  -- we overapproximate here by depending on the GetModIface rule.
-  hiFile  <- use GetModIface f
+  mbHieTimestamp <- either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime hie_f)
+  srcTimestamp   <- MaybeT (either (\(_ :: IOException) -> Nothing) Just <$> (liftIO $ try $ getModificationTime $ fromNormalizedFilePath f))
+  liftIO $ print (mbHieTimestamp, srcTimestamp, hie_f, normal_hie_f)
+  let isUpToDate
+        | Just d <- mbHieTimestamp = d > srcTimestamp
+        | otherwise = False
 
-  case hiFile of
-    Nothing -> return ([], Nothing)
-    Just _ -> liftIO $ do
-        hf <- loadHieFile $ ml_hie_file $ ms_location ms
-        return ([], Just hf)
-      `catch` \e ->
-        if isDoesNotExistError e
-            then return ([], Nothing)
-            else return ([e], Nothing)
+  if isUpToDate
+    then do
+      hf <- liftIO $ whenMaybe isUpToDate (loadHieFile hie_f)
+      MaybeT $ return hf
+    else do
+      wait <- lift $ delayedAction $ mkDelayedAction "OutOfDateHie" L.Info $ do
+        hsc <- hscEnv <$> use_ GhcSession f
+        pm <- use_ GetParsedModule f
+        typeCheckRuleDefinition hsc pm DoGenerateInterfaceFiles
+      _ <- MaybeT $ liftIO $ timeout 1 wait
+      liftIO $ loadHieFile hie_f
 
-getPackageHieFile :: Module             -- ^ Package Module to load .hie file for
+
+getPackageHieFile :: ShakeExtras
+                  -> Module             -- ^ Package Module to load .hie file for
                   -> NormalizedFilePath -- ^ Path of home module importing the package module
-                  -> Action (Maybe (HieFile, FilePath))
-getPackageHieFile mod file = do
-    pkgState  <- hscEnv <$> use_ GhcSession file
-    IdeOptions {..} <- getIdeOptions
+                  -> MaybeT IdeAction (HieFile, FilePath)
+getPackageHieFile ide mod file = do
+    pkgState  <- hscEnv . fst <$> useE GhcSession file
+    IdeOptions {..} <- liftIO $ getIdeOptionsIO ide
     let unitId = moduleUnitId mod
     case lookupPackageConfig unitId pkgState of
         Just pkgConfig -> do
@@ -186,12 +203,12 @@ getPackageHieFile mod file = do
             hieFile <- liftIO $ optLocateHieFile optPkgLocationOpts pkgConfig mod
             path    <- liftIO $ optLocateSrcFile optPkgLocationOpts pkgConfig mod
             case (hieFile, path) of
-                (Just hiePath, Just modPath) ->
+                (Just hiePath, Just modPath) -> MaybeT $
                     -- deliberately loaded outside the Shake graph
                     -- to avoid dependencies on non-workspace files
                         liftIO $ Just . (, modPath) <$> loadHieFile hiePath
-                _ -> return Nothing
-        _ -> return Nothing
+                _ -> MaybeT $ return Nothing
+        _ -> MaybeT $ return Nothing
 
 -- | Parse the contents of a daml file.
 getParsedModule :: NormalizedFilePath -> Action (Maybe ParsedModule)

src/Development/IDE/Core/Service.hs

@@ -9,7 +9,7 @@
 --   using the "Shaker" abstraction layer for in-memory use.
 --
 module Development.IDE.Core.Service(
-    getIdeOptions,
+    getIdeOptions, getIdeOptionsIO,
     IdeState, initialise, shutdown,
     runAction,
     writeProfile,
@@ -20,24 +20,21 @@ module Development.IDE.Core.Service(
 
 import Data.Maybe
 import Development.IDE.Types.Options (IdeOptions(..))
-import Control.Monad
 import Development.IDE.Core.Debouncer
 import           Development.IDE.Core.FileStore  (VFSHandle, fileStoreRules)
 import           Development.IDE.Core.FileExists (fileExistsRules)
 import           Development.IDE.Core.OfInterest
-import Development.IDE.Types.Logger
+import Development.IDE.Types.Logger as Logger
 import           Development.Shake
 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
 
 import           Development.IDE.Core.Shake
+import Control.Monad
 
 
 
-newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions
-instance IsIdeGlobal GlobalIdeOptions
-
 ------------------------------------------------------------
 -- Exposed API
 
@@ -84,10 +81,6 @@ shutdown = shakeShut
 -- 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.
-runAction :: IdeState -> Action a -> IO a
-runAction ide action = join $ shakeEnqueue ide action
-
-getIdeOptions :: Action IdeOptions
-getIdeOptions = do
-    GlobalIdeOptions x <- getIdeGlobalAction
-    return x
+runAction :: String -> IdeState -> Action a -> IO a
+runAction herald ide act =
+  join $ shakeEnqueue ide (mkDelayedAction herald Logger.Info act)

src/Development/IDE/Core/Shake.hs

@@ -30,7 +30,8 @@ module Development.IDE.Core.Shake(
     shakeRestart,
     shakeEnqueue,
     shakeProfile,
-    use, useNoFile, uses,
+    use, useNoFile, uses, useWithStaleFast, useWithStaleFast', delayedAction,
+    FastResult(..),
     use_, useNoFile_, uses_,
     useWithStale, usesWithStale,
     useWithStale_, usesWithStale_,
@@ -38,6 +39,10 @@ module Development.IDE.Core.Shake(
     getDiagnostics, unsafeClearDiagnostics,
     getHiddenDiagnostics,
     IsIdeGlobal, addIdeGlobal, addIdeGlobalExtras, getIdeGlobalState, getIdeGlobalAction,
+    getIdeGlobalExtras,
+    getIdeOptions,
+    getIdeOptionsIO,
+    GlobalIdeOptions(..),
     garbageCollect,
     setPriority,
     sendEvent,
@@ -49,10 +54,12 @@ module Development.IDE.Core.Shake(
     deleteValue,
     OnDiskRule(..),
     WithProgressFunc, WithIndefiniteProgressFunc,
-    ProgressEvent(..)
+    ProgressEvent(..),
+    DelayedAction, mkDelayedAction,
+    IdeAction(..), runIdeAction
     ) where
 
-import           Development.Shake hiding (ShakeValue, doesFileExist)
+import           Development.Shake hiding (ShakeValue, doesFileExist, Info)
 import           Development.Shake.Database
 import           Development.Shake.Classes
 import           Development.Shake.Rule
@@ -65,12 +72,12 @@ import Data.Map.Strict (Map)
 import           Data.List.Extra (partition, takeEnd)
 import qualified Data.Set as Set
 import qualified Data.Text as T
-import Data.Traversable (for)
 import Data.Tuple.Extra
 import Data.Unique
 import Development.IDE.Core.Debouncer
 import Development.IDE.Core.PositionMapping
 import Development.IDE.Types.Logger hiding (Priority)
+import qualified Development.IDE.Types.Logger as Logger
 import Language.Haskell.LSP.Diagnostics
 import qualified Data.SortedList as SL
 import           Development.IDE.Types.Diagnostics
@@ -96,6 +103,9 @@ import           System.IO.Unsafe
 import Language.Haskell.LSP.Types
 import Data.Foldable (traverse_)
 import qualified Control.Monad.STM as STM
+import Control.Monad.IO.Class
+import Control.Monad.Reader
+import Data.Traversable
 
 
 -- information we stash inside the shakeExtra field
@@ -119,12 +129,15 @@ data ShakeExtras = ShakeExtras
     -- ^ How many rules are running for each file
     ,progressUpdate :: ProgressEvent -> IO ()
     -- ^ The generator for unique Lsp identifiers
-    ,restartShakeSession :: [Action ()] -> IO ()
+    ,ideTesting :: IdeTesting
+    -- ^ Whether to enable additional lsp messages used by the test suite for checking invariants
+    ,session :: MVar ShakeSession
     -- ^ Used in the GhcSession rule to forcefully restart the session after adding a new component
     ,withProgress           :: WithProgressFunc
     -- ^ Report progress about some long running operation (on top of the progress shown by 'lspShakeProgress')
     ,withIndefiniteProgress :: WithIndefiniteProgressFunc
     -- ^ Same as 'withProgress', but for processes that do not report the percentage complete
+    ,restartShakeSession :: [DelayedAction ()] -> IO ()
     }
 
 type WithProgressFunc = forall a.
@@ -193,6 +206,19 @@ instance Eq Key where
 instance Hashable Key where
     hashWithSalt salt (Key key) = hashWithSalt salt (typeOf key, key)
 
+newtype GlobalIdeOptions = GlobalIdeOptions IdeOptions
+instance IsIdeGlobal GlobalIdeOptions
+
+getIdeOptions :: Action IdeOptions
+getIdeOptions = do
+    GlobalIdeOptions x <- getIdeGlobalAction
+    return x
+
+getIdeOptionsIO :: ShakeExtras -> IO IdeOptions
+getIdeOptionsIO ide = do
+    GlobalIdeOptions x <- getIdeGlobalExtras ide
+    return x
+
 data Value v
     = Succeeded TextDocumentVersion v
     | Stale TextDocumentVersion v
@@ -210,15 +236,21 @@ currentValue Failed = Nothing
 
 -- | Return the most recent, potentially stale, value and a PositionMapping
 -- for the version of that value.
-lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))
-lastValue file v = do
-    ShakeExtras{positionMapping} <- getShakeExtras
+lastValueIO :: ShakeExtras -> NormalizedFilePath -> Value v -> IO (Maybe (v, PositionMapping))
+lastValueIO ShakeExtras{positionMapping} file v = do
     allMappings <- liftIO $ readVar positionMapping
     pure $ case v of
         Succeeded ver v -> Just (v, mappingForVersion allMappings file ver)
         Stale ver v -> Just (v, mappingForVersion allMappings file ver)
         Failed -> Nothing
 
+-- | Return the most recent, potentially stale, value and a PositionMapping
+-- for the version of that value.
+lastValue :: NormalizedFilePath -> Value v -> Action (Maybe (v, PositionMapping))
+lastValue file v = do
+    s <- getShakeExtras
+    liftIO $ lastValueIO s file v
+
 valueVersion :: Value v -> Maybe TextDocumentVersion
 valueVersion = \case
     Succeeded ver _ -> Just ver
@@ -246,15 +278,12 @@ type IdeRule k 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 ()])
+  { cancelShakeSession :: !(IO [DelayedActionInternal])
     -- ^ 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.
+  , runInShakeSession  :: !(forall a . DelayedAction a -> IO (IO a))
+    -- ^ Enqueue an 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
@@ -267,6 +296,7 @@ data IdeState = IdeState
     }
 
 
+
 -- This is debugging code that generates a series of profiles, if the Boolean is true
 shakeDatabaseProfile :: Maybe FilePath -> ShakeDatabase -> IO (Maybe FilePath)
 shakeDatabaseProfile mbProfileDir shakeDb =
@@ -340,7 +370,7 @@ shakeOpen :: IO LSP.LspId
           -> Rules ()
           -> IO IdeState
 shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
-  shakeProfileDir (IdeReportProgress reportProgress) (IdeTesting ideTesting) opts rules = mdo
+  shakeProfileDir (IdeReportProgress reportProgress) ideTesting@(IdeTesting testing) opts rules = mdo
 
     inProgress <- newVar HMap.empty
     (shakeExtras, stopProgressReporting) <- do
@@ -351,6 +381,7 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
         publishedDiagnostics <- newVar mempty
         positionMapping <- newVar HMap.empty
         let restartShakeSession = shakeRestart ideState
+        let session = shakeSession
         mostRecentProgressEvent <- newTVarIO KickCompleted
         let progressUpdate = atomically . writeTVar mostRecentProgressEvent
         progressAsync <- async $
@@ -362,8 +393,9 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
         shakeOpenDatabase
             opts { shakeExtra = addShakeExtra shakeExtras $ shakeExtra opts }
             rules
-    shakeSession <- newMVar emptyShakeSession
     shakeDb <- shakeDbM
+    initSession <- newSession shakeExtras shakeDb [] []
+    shakeSession <- newMVar initSession
     let ideState = IdeState{..}
     return ideState
     where
@@ -395,7 +427,7 @@ shakeOpen getLspId eventer withProgress withIndefiniteProgress logger debouncer
             lspShakeProgress = 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)
-                unless ideTesting $ sleep 0.1
+                unless testing $ sleep 0.1
                 lspId <- getLspId
                 u <- ProgressTextToken . T.pack . show . hashUnique <$> newUnique
                 eventer $ LSP.ReqWorkDoneProgressCreate $
@@ -453,6 +485,7 @@ shakeShut IdeState{..} = withMVar shakeSession $ \runner -> do
     shakeClose
     stopProgressReporting
 
+
 -- | 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 b) -> (b -> IO (a, c)) -> IO c
@@ -463,12 +496,35 @@ withMVar' var unmasked masked = mask $ \restore -> do
     putMVar var a'
     pure c
 
+
+mkDelayedAction :: String -> Logger.Priority -> Action a -> DelayedAction a
+mkDelayedAction = DelayedAction
+
+data DelayedAction a = DelayedAction
+  { actionName :: String -- ^ Name we use for debugging
+  , actionPriority :: Logger.Priority -- ^ Priority with which to log the action
+  , getAction :: Action a -- ^ The payload
+  }
+
+type DelayedActionInternal = DelayedAction ()
+
+instance Show (DelayedAction a) where
+    show d = "DelayedAction: " ++ actionName d
+
+-- | These actions are run asynchronously after the current action is
+-- finished running. For example, to trigger a key build after a rule
+-- has already finished as is the case with useWithStaleFast
+delayedAction :: DelayedAction a -> IdeAction (IO a)
+delayedAction a = do
+  sq <- asks session
+  liftIO $ shakeEnqueueSession sq a
+
 -- | 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 =
+shakeRestart :: IdeState -> [DelayedAction a] -> IO ()
+shakeRestart IdeState{..} systemActs =
     withMVar'
         shakeSession
         (\runner -> do
@@ -477,7 +533,7 @@ shakeRestart it@IdeState{shakeExtras=ShakeExtras{logger}, ..} systemActs =
               let profile = case res of
                       Just fp -> ", profile saved at " <> fp
                       _ -> ""
-              logDebug logger $ T.pack $
+              logDebug (logger shakeExtras) $ T.pack $
                   "Restarting build session (aborting the previous one took " ++
                   showDuration stopTime ++ profile ++ ")"
               return queue
@@ -485,29 +541,33 @@ shakeRestart it@IdeState{shakeExtras=ShakeExtras{logger}, ..} systemActs =
         -- It is crucial to be masked here, otherwise we can get killed
         -- between spawning the new thread and updating shakeSession.
         -- See https://github.com/digital-asset/ghcide/issues/79
-        (fmap (,()) . newSession it systemActs)
+        (\cancelled -> do
+          (_b, dai) <- unzip <$> mapM instantiateDelayedAction systemActs
+          (,()) <$> newSession shakeExtras shakeDb dai cancelled)
 
 -- | 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
+shakeEnqueue :: IdeState -> DelayedAction a -> IO (IO a)
+shakeEnqueue IdeState{shakeSession} act = shakeEnqueueSession shakeSession act
+
+shakeEnqueueSession :: MVar ShakeSession -> DelayedAction a -> IO (IO a)
+shakeEnqueueSession sess act = withMVar sess $ \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
+newSession :: ShakeExtras -> ShakeDatabase -> [DelayedActionInternal] -> [DelayedActionInternal] -> IO ShakeSession
+newSession ShakeExtras{..} shakeDb systemActs userActs = do
     -- A work queue for actions added via 'runInShakeSession'
-    actionQueue :: TQueue (Action ()) <- atomically $ do
+    actionQueue :: TQueue DelayedActionInternal <- atomically $ do
         q <- newTQueue
         traverse_ (writeTQueue q) userActs
         return q
-    actionInProgress :: TVar (Maybe (Action())) <- newTVarIO Nothing
+    actionInProgress :: TVar (Maybe DelayedActionInternal) <- newTVarIO Nothing
 
     let
         -- A daemon-like action used to inject additional work
@@ -517,11 +577,11 @@ newSession IdeState{shakeExtras=ShakeExtras{..}, ..} systemActs userActs = do
                 join $ liftIO $ atomically $ do
                     act <- readTQueue actionQueue
                     writeTVar actionInProgress $ Just act
-                    return act
+                    return (logDelayedAction logger act)
                 liftIO $ atomically $ writeTVar actionInProgress Nothing
 
         workRun restore = do
-          let systemActs' = pumpAction : systemActs
+          let systemActs' = pumpAction : map getAction systemActs
           res <- try @SomeException
                  (restore $ shakeRunDatabase shakeDb systemActs')
           let res' = case res of
@@ -538,24 +598,18 @@ newSession IdeState{shakeExtras=ShakeExtras{..}, ..} systemActs userActs = do
     -- 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' = do
-                    -- work gets reenqueued when the Shake session is restarted
-                    -- it can happen that a work item finished just as it was reenqueud
-                    -- in that case, skipping the work is fine
-                    alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe res
-                    unless alreadyDone $ do
-                        x <- actionCatch @SomeException (Right <$> act) (pure . Left)
-                        liftIO $ signalBarrier res x
-              atomically $ writeTQueue actionQueue act'
-              return (waitBarrier res >>= either throwIO return)
+    let runInShakeSession :: forall a . DelayedAction a -> IO (IO a)
+        runInShakeSession da = do
+          (b, dai) <- instantiateDelayedAction da
+          atomically $ writeTQueue actionQueue dai
+          return (waitBarrier b >>= either throwIO return)
 
     --  Cancelling is required to flush the Shake database when either
     --  the filesystem or the Ghc configuration have changed
+        cancelShakeSession :: IO [DelayedActionInternal]
         cancelShakeSession = do
             cancel workThread
             atomically $ do
@@ -565,6 +619,28 @@ newSession IdeState{shakeExtras=ShakeExtras{..}, ..} systemActs userActs = do
 
     pure (ShakeSession{..})
 
+instantiateDelayedAction :: DelayedAction a -> IO (Barrier (Either SomeException a), DelayedActionInternal)
+instantiateDelayedAction (DelayedAction s p a) = do
+  b <- newBarrier
+  let a' = do 
+        -- work gets reenqueued when the Shake session is restarted
+        -- it can happen that a work item finished just as it was reenqueud
+        -- in that case, skipping the work is fine
+        alreadyDone <- liftIO $ isJust <$> waitBarrierMaybe b
+        unless alreadyDone $ do
+          x <- actionCatch @SomeException (Right <$> a) (pure . Left)
+          liftIO $ signalBarrier b x
+  let d = DelayedAction s p a'
+  return (b, d)
+
+logDelayedAction :: Logger -> DelayedActionInternal -> Action ()
+logDelayedAction l d  = do
+    start <- liftIO offsetTime
+    getAction d
+    runTime <- liftIO start
+    liftIO $ logPriority l (actionPriority d) $ T.pack $
+        "finish: " ++ actionName d ++ " (took " ++ showDuration runTime ++ ")"
+
 getDiagnostics :: IdeState -> IO [FileDiagnostic]
 getDiagnostics IdeState{shakeExtras = ShakeExtras{diagnostics}} = do
     val <- readVar diagnostics
@@ -620,6 +696,55 @@ usesWithStale_ key files = do
         Nothing -> liftIO $ throwIO $ BadDependency (show key)
         Just v -> return v
 
+newtype IdeAction a = IdeAction { runIdeActionT  :: (ReaderT ShakeExtras IO) a }
+    deriving (MonadReader ShakeExtras, MonadIO, Functor, Applicative, Monad)
+
+-- | IdeActions are used when we want to return a result immediately, even if it
+-- is stale Useful for UI actions like hover, completion where we don't want to
+-- block.
+runIdeAction :: String -> ShakeExtras -> IdeAction a -> IO a
+runIdeAction _herald s i = runReaderT (runIdeActionT i) s
+
+askShake :: IdeAction ShakeExtras
+askShake = ask
+
+-- | A (maybe) stale result now, and an up to date one later
+data FastResult a = FastResult { stale :: Maybe (a,PositionMapping), uptoDate :: IO (Maybe a)  }
+
+-- | Lookup value in the database and return with the stale value immediately
+-- Will queue an action to refresh the value.
+-- Might block the first time the rule runs, but never blocks after that.
+useWithStaleFast :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (Maybe (v, PositionMapping))
+useWithStaleFast key file = stale <$> useWithStaleFast' key file
+
+-- | Same as useWithStaleFast but lets you wait for an up to date result
+useWithStaleFast' :: IdeRule k v => k -> NormalizedFilePath -> IdeAction (FastResult v)
+useWithStaleFast' key file = do
+  -- This lookup directly looks up the key in the shake database and
+  -- returns the last value that was computed for this key without
+  -- checking freshness.
+
+  -- Async trigger the key to be built anyway because we want to
+  -- keep updating the value in the key.
+  wait <- delayedAction $ mkDelayedAction ("C:" ++ show key) Debug $ use key file
+
+  s@ShakeExtras{state} <- askShake
+  r <- liftIO $ getValues state key file
+  liftIO $ case r of
+    -- block for the result if we haven't computed before
+    Nothing -> do
+      a <- wait
+      r <- getValues state key file
+      case r of
+        Nothing -> return $ FastResult Nothing (pure a)
+        Just v -> do
+          res <- lastValueIO s file v
+          pure $ FastResult res (pure a)
+    -- Otherwise, use the computed value even if it's out of date.
+    Just v -> do
+      res <- lastValueIO s file v
+      pure $ FastResult res wait
+
 useNoFile :: IdeRule k v => k -> Action (Maybe v)
 useNoFile key = use key emptyFilePath
 
@@ -843,12 +968,12 @@ decodeShakeValue bs = case BS.uncons bs of
       | otherwise -> error $ "Failed to parse shake value " <> show bs
 
 
-updateFileDiagnostics ::
-     NormalizedFilePath
+updateFileDiagnostics :: MonadIO m
+  => NormalizedFilePath
   -> Key
   -> ShakeExtras
   -> [(ShowDiagnostic,Diagnostic)] -- ^ current results
-  -> Action ()
+  -> m ()
 updateFileDiagnostics fp k ShakeExtras{diagnostics, hiddenDiagnostics, publishedDiagnostics, state, debouncer, eventer} current = liftIO $ do
     modTime <- (currentValue =<<) <$> getValues state GetModificationTime fp
     let (currentShown, currentHidden) = partition ((== ShowDiag) . fst) current

src/Development/IDE/LSP/HoverDefinition.hs

@@ -14,17 +14,15 @@ module Development.IDE.LSP.HoverDefinition
     ) where
 
 import           Development.IDE.Core.Rules
-import           Development.IDE.Core.Service
+import           Development.IDE.Core.Shake
 import           Development.IDE.LSP.Server
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Logger
-import           Development.Shake
 import qualified Language.Haskell.LSP.Core       as LSP
 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))
@@ -48,7 +46,7 @@ setHandlersHover      = PartialHandlers $ \WithMessage{..} x ->
 -- | Respond to and log a hover or go-to-definition request
 request
   :: T.Text
-  -> (NormalizedFilePath -> Position -> Action (Maybe a))
+  -> (NormalizedFilePath -> Position -> IdeAction (Maybe a))
   -> b
   -> (a -> b)
   -> IdeState
@@ -60,11 +58,10 @@ request label getResults notFound found ide (TextDocumentPositionParams (TextDoc
         Nothing   -> pure Nothing
     pure $ Right $ maybe notFound found mbResult
 
-logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> Action b) -> IdeState -> Position -> String -> IO b
+logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b
 logAndRunRequest label getResults ide pos path = do
   let filePath = toNormalizedFilePath' path
-  (t, res) <- duration $ runAction ide $ getResults filePath pos
-  logDebug (ideLogger ide) $
+  logInfo (ideLogger ide) $
     label <> " request at position " <> T.pack (showPosition pos) <>
-    " in file: " <> T.pack path <> " took " <> T.pack (showDuration t)
-  return res
+    " in file: " <> T.pack path
+  runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos)

src/Development/IDE/LSP/Notifications.hs

@@ -24,7 +24,7 @@ import           Data.Maybe
 import qualified Data.HashSet                     as S
 import qualified Data.Text                        as Text
 
-import           Development.IDE.Core.FileStore   (setSomethingModified)
+import           Development.IDE.Core.FileStore   (setSomethingModified, setFileModified)
 import           Development.IDE.Core.FileExists  (modifyFileExists)
 import           Development.IDE.Core.OfInterest
 
@@ -39,17 +39,18 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
             updatePositionMapping ide (VersionedTextDocumentIdentifier _uri (Just _version)) (List [])
             whenUriFile _uri $ \file -> do
                 modifyFilesOfInterest ide (S.insert file)
+                setFileModified ide file
                 logInfo (ideLogger ide) $ "Opened text document: " <> getUri _uri
 
     ,LSP.didChangeTextDocumentNotificationHandler = withNotification (LSP.didChangeTextDocumentNotificationHandler x) $
         \_ ide (DidChangeTextDocumentParams identifier@VersionedTextDocumentIdentifier{_uri} changes) -> do
             updatePositionMapping ide identifier changes
-            setSomethingModified ide
+            whenUriFile _uri $ \file -> setFileModified ide file
             logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri
 
     ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $
         \_ ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do
-            setSomethingModified ide
+            whenUriFile _uri $ \file -> setFileModified ide file
             logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri
 
     ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $

src/Development/IDE/LSP/Outline.hs

@@ -40,7 +40,7 @@ moduleOutline
 moduleOutline _lsp ideState DocumentSymbolParams { _textDocument = TextDocumentIdentifier uri }
   = case uriToFilePath uri of
     Just (toNormalizedFilePath' -> fp) -> do
-      mb_decls <- runAction ideState $ use GetParsedModule fp
+      mb_decls <- fmap fst <$> runIdeAction "Outline" (shakeExtras ideState) (useWithStaleFast GetParsedModule fp)
       pure $ Right $ case mb_decls of
         Nothing -> DSDocumentSymbols (List [])
         Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } }

src/Development/IDE/Plugin/CodeAction.hs

@@ -32,7 +32,6 @@ 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
@@ -41,7 +40,6 @@ import Language.Haskell.LSP.VFS
 import Language.Haskell.LSP.Messages
 import qualified Data.Rope.UTF16 as Rope
 import Data.Aeson.Types (toJSON, fromJSON, Value(..), Result(..))
-import Control.Monad.Trans.Maybe
 import Data.Char
 import Data.Maybe
 import Data.List.Extra
@@ -55,7 +53,6 @@ import Text.Regex.TDFA.Text()
 import Outputable (ppr, showSDocUnsafe)
 import DynFlags (xFlags, FlagSpec(..))
 import GHC.LanguageExtensions.Type (Extension)
-import System.Time.Extra (showDuration, duration)
 import Data.Function
 import Control.Arrow ((>>>))
 import Data.Functor
@@ -76,30 +73,20 @@ codeAction
     -> IO (Either ResponseError [CAResult])
 codeAction lsp state (TextDocumentIdentifier uri) _range CodeActionContext{_diagnostics=List xs} = do
     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
-    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
+    let text = Rope.toText . (_text :: VirtualFile -> Rope.Rope) <$> contents
+        mbFile = toNormalizedFilePath' <$> uriToFilePath uri
+    (ideOptions, parsedModule, join -> env) <- runAction "CodeAction" state $
+      (,,) <$> getIdeOptions
+            <*> getParsedModule `traverse` mbFile
+            <*> use GhcSession `traverse` mbFile
+    -- This is quite expensive 0.6-0.7s on GHC
+    pkgExports <- runAction "CodeAction:PackageExports" 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
+        ]
 
 -- | Generate code lenses.
 codeLens
@@ -111,7 +98,7 @@ codeLens _lsp ideState CodeLensParams{_textDocument=TextDocumentIdentifier uri}
     commandId <- makeLspCommandId "typesignature.add"
     fmap (Right . List) $ case uriToFilePath' uri of
       Just (toNormalizedFilePath' -> filePath) -> do
-        _ <- runAction ideState $ runMaybeT $ useE TypeCheck filePath
+        _ <- runAction "codeLens" ideState (use TypeCheck filePath)
         diag <- getDiagnostics ideState
         hDiag <- getHiddenDiagnostics ideState
         pure

src/Development/IDE/Plugin/Completions.hs

@@ -18,14 +18,11 @@ 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
@@ -79,12 +76,12 @@ getCompletionsLSP lsp ide
                   ,_context=completionContext} = do
     contents <- LSP.getVirtualFileFunc lsp $ toNormalizedUri uri
     fmap Right $ case (contents, uriToFilePath' uri) of
-      (Just cnts, Just path) -> logAndRunRequest ide path $ do
+      (Just cnts, Just path) -> do
         let npath = toNormalizedFilePath' path
-        (ideOpts, compls) <- runAction ide $ do
-            opts <- getIdeOptions
-            compls <- useWithStale ProduceCompletions npath
-            pm <- useWithStale GetParsedModule npath
+        (ideOpts, compls) <- runIdeAction "Completion" (shakeExtras ide) $ do
+            opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
+            compls <- useWithStaleFast ProduceCompletions npath
+            pm <- useWithStaleFast GetParsedModule npath
             pure (opts, liftA2 (,) compls pm)
         case compls of
           Just ((cci', _), (pm, mapping)) -> do
@@ -100,14 +97,6 @@ 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/Spans/AtPoint.hs

@@ -30,6 +30,7 @@ import VarSet
 
 import Control.Monad.Extra
 import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Class
 import Control.Monad.IO.Class
 import           Data.Maybe
 import           Data.List
@@ -37,24 +38,24 @@ import qualified Data.Text as T
 
 gotoTypeDefinition
   :: MonadIO m
-  => (Module -> m (Maybe (HieFile, FilePath)))
+  => (Module -> MaybeT m (HieFile, FilePath))
   -> IdeOptions
   -> [SpanInfo]
   -> Position
-  -> m [Location]
+  -> MaybeT m [Location]
 gotoTypeDefinition getHieFile ideOpts srcSpans pos
   = typeLocationsAtPoint getHieFile ideOpts pos srcSpans
 
 -- | Locate the definition of the name at a given position.
 gotoDefinition
   :: MonadIO m
-  => (Module -> m (Maybe (HieFile, FilePath)))
+  => (Module -> MaybeT m (HieFile, FilePath))
   -> IdeOptions
   -> [SpanInfo]
   -> Position
-  -> m (Maybe Location)
+  -> MaybeT m Location
 gotoDefinition getHieFile ideOpts srcSpans pos =
-  listToMaybe <$> locationsAtPoint getHieFile ideOpts pos srcSpans
+  MaybeT . pure . listToMaybe =<< locationsAtPoint getHieFile ideOpts pos srcSpans
 
 -- | Synopsis for the name at a given position.
 atPoint
@@ -128,15 +129,14 @@ atPoint IdeOptions{..} (SpansInfo srcSpans cntsSpans) pos = do
 
 
 
-
 typeLocationsAtPoint
   :: forall m
    . MonadIO m
-  => (Module -> m (Maybe (HieFile, FilePath)))
+  => (Module -> MaybeT m (HieFile, FilePath))
   -> IdeOptions
   -> Position
   -> [SpanInfo]
-  -> m [Location]
+  -> MaybeT m [Location]
 typeLocationsAtPoint getHieFile = querySpanInfoAt getTypeSpan
   where getTypeSpan :: SpanInfo -> m (Maybe SrcSpan)
         getTypeSpan SpanInfo { spaninfoType = Just t } =
@@ -149,11 +149,11 @@ typeLocationsAtPoint getHieFile = querySpanInfoAt getTypeSpan
 locationsAtPoint
   :: forall m
    . MonadIO m
-  => (Module -> m (Maybe (HieFile, FilePath)))
+  => (Module -> MaybeT m (HieFile, FilePath))
   -> IdeOptions
   -> Position
   -> [SpanInfo]
-  -> m [Location]
+  -> MaybeT m [Location]
 locationsAtPoint getHieFile = querySpanInfoAt (getSpan . spaninfoSource)
   where getSpan :: SpanSource -> m (Maybe SrcSpan)
         getSpan NoSource = pure Nothing
@@ -167,12 +167,12 @@ querySpanInfoAt :: forall m
   -> IdeOptions
   -> Position
   -> [SpanInfo]
-  -> m [Location]
+  -> MaybeT m [Location]
 querySpanInfoAt getSpan _ideOptions pos =
-    fmap (map srcSpanToLocation) . mapMaybeM getSpan . spansAtPoint pos
+    lift . fmap (map srcSpanToLocation) . mapMaybeM getSpan . spansAtPoint pos
 
 -- | Given a 'Name' attempt to find the location where it is defined.
-nameToLocation :: Monad f => (Module -> f (Maybe (HieFile, String))) -> Name -> f (Maybe SrcSpan)
+nameToLocation :: Monad f => (Module -> MaybeT f (HieFile, String)) -> Name -> f (Maybe SrcSpan)
 nameToLocation getHieFile name =
   case nameSrcSpan name of
     sp@(RealSrcSpan _) -> pure $ Just sp
@@ -182,7 +182,7 @@ nameToLocation getHieFile name =
       -- In this case the interface files contain garbage source spans
       -- so we instead read the .hie files to get useful source spans.
       mod <- MaybeT $ return $ nameModule_maybe name
-      (hieFile, srcPath) <- MaybeT $ getHieFile mod
+      (hieFile, srcPath) <- getHieFile mod
       avail <- MaybeT $ pure $ find (eqName name . snd) $ hieExportNames hieFile
       -- The location will point to the source file used during compilation.
       -- This file might no longer exists and even if it does the path will be relative