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 <[email protected]>

Author: mpickering

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,78 +124,91 @@ 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
-
-getTypeDefinition :: NormalizedFilePath -> Position -> Action (Maybe [Location])
+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 -> 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
-
-  -- .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
-
-  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)
-
-getPackageHieFile :: Module             -- ^ Package Module to load .hie file for
+  ms <- fst <$> useE GetModSummary f
+  let normal_hie_f = toNormalizedFilePath' hie_f
+      hie_f = ml_hie_file $ ms_location ms
+
+  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
+
+  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 :: 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
             -- 'optLocateHieFile' returns Nothing if the file does not exist
             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)