Use stale information if it's available to answer requests quickly

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)