Fix performance of getFileExists (#322)

* Improve hover performance by speeding up getFileExists

We touch the file system only the first time.
After that, we rely on the lsp client to tell us if a file is created or deleted

Fixes #101

exe/Main.hs

@@ -93,10 +93,10 @@ main = do
             -- very important we only call loadSession once, and it's fast, so just do it before starting
             session <- loadSession dir
             let options = (defaultIdeOptions $ return session)
-                    { optReportProgress = clientSupportsProgress caps 
+                    { optReportProgress = clientSupportsProgress caps
                     , optShakeProfiling = argsShakeProfiling
                     }
-            initialise (mainRule >> action kick) getLspId event (logger minBound) options vfs
+            initialise caps (mainRule >> action kick) getLspId event (logger minBound) options vfs
     else do
         putStrLn $ "Ghcide setup tester in " ++ dir ++ "."
         putStrLn "Report bugs at https://github.com/digital-asset/ghcide/issues"
@@ -125,7 +125,7 @@ main = do
         let grab file = fromMaybe (head sessions) $ do
                 cradle <- Map.lookup file filesToCradles
                 Map.lookup cradle cradlesToSessions
-        ide <- initialise mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs
+        ide <- initialise def mainRule (pure $ IdInt 0) (showEvent lock) (logger Info) (defaultIdeOptions $ return $ return . grab) vfs
 
         putStrLn "\nStep 6/6: Type checking the files"
         setFilesOfInterest ide $ Set.fromList $ map toNormalizedFilePath files

ghcide.cabal

@@ -121,6 +121,7 @@ library
         Development.IDE.Core.Debouncer
         Development.IDE.Core.Compile
         Development.IDE.Core.Preprocessor
+        Development.IDE.Core.FileExists
         Development.IDE.GHC.Compat
         Development.IDE.GHC.CPP
         Development.IDE.GHC.Error
@@ -230,4 +231,16 @@ test-suite ghcide-tests
         Development.IDE.Test
         Development.IDE.Test.Runfiles
     default-extensions:
+        BangPatterns
+        DeriveFunctor
+        DeriveGeneric
+        GeneralizedNewtypeDeriving
+        LambdaCase
+        NamedFieldPuns
         OverloadedStrings
+        RecordWildCards
+        ScopedTypeVariables
+        StandaloneDeriving
+        TupleSections
+        TypeApplications
+        ViewPatterns

src/Development/IDE/Core/FileExists.hs

@@ -0,0 +1,187 @@
+{-# LANGUAGE OverloadedLists      #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE UndecidableInstances #-}
+module Development.IDE.Core.FileExists
+  ( fileExistsRules
+  , modifyFileExists
+  , getFileExists
+  )
+where
+
+import           Control.Concurrent.Extra
+import           Control.Exception
+import           Control.Monad.Extra
+import qualified Data.Aeson                    as A
+import           Data.Binary
+import qualified Data.ByteString               as BS
+import           Data.Map.Strict                ( Map )
+import qualified Data.Map.Strict               as Map
+import           Data.Maybe
+import qualified Data.Text                     as T
+import           Development.IDE.Core.FileStore
+import           Development.IDE.Core.Shake
+import           Development.IDE.Types.Location
+import           Development.Shake
+import           Development.Shake.Classes
+import           GHC.Generics
+import           Language.Haskell.LSP.Messages
+import           Language.Haskell.LSP.Types
+import           Language.Haskell.LSP.Types.Capabilities
+import qualified System.Directory as Dir
+
+-- | A map for tracking the file existence
+type FileExistsMap = (Map NormalizedFilePath Bool)
+
+-- | A wrapper around a mutable 'FileExistsMap'
+newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
+
+instance IsIdeGlobal FileExistsMapVar
+
+-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency
+getFileExistsMapUntracked :: Action FileExistsMap
+getFileExistsMapUntracked = do
+  FileExistsMapVar v <- getIdeGlobalAction
+  liftIO $ readVar v
+
+-- | Modify the global store of file exists
+modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action ()
+modifyFileExistsAction f = do
+  FileExistsMapVar var <- getIdeGlobalAction
+  liftIO $ modifyVar_ var f
+
+-- | Modify the global store of file exists
+modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
+modifyFileExists state changes = do
+  FileExistsMapVar var <- getIdeGlobalState state
+  changesMap           <- evaluate $ Map.fromList changes
+
+  -- Masked to ensure that the previous values are flushed together with the map update
+  mask $ \_ -> do
+    -- update the map
+    modifyVar_ var $ evaluate . Map.union changesMap
+    -- flush previous values
+    mapM_ (deleteValue state GetFileExists . fst) changes
+
+-------------------------------------------------------------------------------------
+
+type instance RuleResult GetFileExists = Bool
+
+data GetFileExists = GetFileExists
+    deriving (Eq, Show, Typeable, Generic)
+
+instance NFData   GetFileExists
+instance Hashable GetFileExists
+instance Binary   GetFileExists
+
+-- | Returns True if the file exists
+--   Note that a file is not considered to exist unless it is saved to disk.
+--   In particular, VFS existence is not enough.
+--   Consider the following example:
+--     1. The file @A.hs@ containing the line @import B@ is added to the files of interest
+--        Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing
+--     2. The editor creates a new buffer @B.hs@
+--        Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up
+--        Most editors, e.g. VSCode, only send the event when the file is saved to disk.
+getFileExists :: NormalizedFilePath -> Action Bool
+getFileExists fp = use_ GetFileExists fp
+
+-- | Installs the 'getFileExists' rules.
+--   Provides a fast implementation if client supports dynamic watched files.
+--   Creates a global state as a side effect in that case.
+fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
+fileExistsRules getLspId ClientCapabilities{_workspace}
+  | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
+  , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
+  , Just True <- _dynamicRegistration
+  = fileExistsRulesFast getLspId
+  | otherwise = fileExistsRulesSlow
+
+--   Requires an lsp client that provides WatchedFiles notifications.
+fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
+fileExistsRulesFast getLspId vfs = do
+  addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
+  defineEarlyCutoff $ \GetFileExists file -> do
+    fileExistsMap <- getFileExistsMapUntracked
+    let mbFilesWatched = Map.lookup file fileExistsMap
+    case mbFilesWatched of
+      Just fv -> pure (summarizeExists fv, ([], Just fv))
+      Nothing -> do
+        exist                   <- liftIO $ getFileExistsVFS vfs file
+        ShakeExtras { eventer } <- getShakeExtras
+
+        -- add a listener for VFS Create/Delete file events,
+        -- taking the FileExistsMap lock to prevent race conditions
+        -- that would lead to multiple listeners for the same path
+        modifyFileExistsAction $ \x -> do
+          case Map.insertLookupWithKey (\_ x _ -> x) file exist x of
+            (Nothing, x') -> do
+            -- if the listener addition fails, we never recover. This is a bug.
+              addListener eventer file
+              return x'
+            (Just _, _) ->
+              -- if the key was already there, do nothing
+              return x
+
+        pure (summarizeExists exist, ([], Just exist))
+ where
+  addListener eventer fp = do
+    reqId <- getLspId
+    let
+      req = RequestMessage "2.0" reqId ClientRegisterCapability regParams
+      fpAsId       = T.pack $ fromNormalizedFilePath fp
+      regParams    = RegistrationParams (List [registration])
+      registration = Registration fpAsId
+                                  WorkspaceDidChangeWatchedFiles
+                                  (Just (A.toJSON regOptions))
+      regOptions =
+        DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }
+      watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp
+                                  , kind        = Just 5 -- Create and Delete events only
+                                  }
+
+    eventer $ ReqRegisterCapability req
+
+summarizeExists :: Bool -> Maybe BS.ByteString
+summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
+
+fileExistsRulesSlow:: VFSHandle -> Rules ()
+fileExistsRulesSlow vfs = do
+  defineEarlyCutoff $ \GetFileExists file -> do
+    alwaysRerun
+    exist <- liftIO $ getFileExistsVFS vfs file
+    pure (summarizeExists exist, ([], Just exist))
+
+getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool
+getFileExistsVFS vfs file = do
+    -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
+    -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
+    -- cached 'No' rather than an exception in the wrong place
+    handle (\(_ :: IOException) -> return False) $
+        (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
+        Dir.doesFileExist (fromNormalizedFilePath file)
+
+--------------------------------------------------------------------------------------------------
+-- The message definitions below probably belong in haskell-lsp-types
+
+data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions
+    { watchers :: List FileSystemWatcher
+    }
+
+instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where
+  toJSON DidChangeWatchedFilesRegistrationOptions {..} =
+    A.object ["watchers" A..= watchers]
+
+data FileSystemWatcher = FileSystemWatcher
+    { -- | The glob pattern to watch.
+      --   For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles
+      globPattern :: String
+        -- | The kind of event to subscribe to. Defaults to all.
+        --   Defined as a bitmap of Create(1), Change(2), and Delete(4)
+    , kind        :: Maybe Int
+    }
+
+instance A.ToJSON FileSystemWatcher where
+  toJSON FileSystemWatcher {..} =
+    A.object
+      $  ["globPattern" A..= globPattern]
+      ++ [ "kind" A..= x | Just x <- [kind] ]

src/Development/IDE/Core/FileStore.hs

@@ -4,7 +4,8 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module Development.IDE.Core.FileStore(
-    getFileExists, getFileContents,
+    getFileContents,
+    getVirtualFile,
     setBufferModified,
     setSomethingModified,
     fileStoreRules,
@@ -20,16 +21,14 @@ import Fingerprint
 import           StringBuffer
 import Development.IDE.GHC.Orphans()
 import Development.IDE.GHC.Util
-
+import           Development.IDE.Core.Shake
 import Control.Concurrent.Extra
 import qualified Data.Map.Strict as Map
 import Data.Maybe
 import qualified Data.Text as T
 import           Control.Monad.Extra
-import qualified System.Directory as Dir
 import           Development.Shake
 import           Development.Shake.Classes
-import           Development.IDE.Core.Shake
 import           Control.Exception
 import           GHC.Generics
 import Data.Either.Extra
@@ -90,17 +89,8 @@ makeLSPVFSHandle lspFuncs = VFSHandle
 -- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
 type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
 
--- | Does the file exist.
-type instance RuleResult GetFileExists = Bool
-
 type instance RuleResult FingerprintSource = Fingerprint
 
-data GetFileExists = GetFileExists
-    deriving (Eq, Show, Generic)
-instance Hashable GetFileExists
-instance NFData   GetFileExists
-instance Binary   GetFileExists
-
 data GetFileContents = GetFileContents
     deriving (Eq, Show, Generic)
 instance Hashable GetFileContents
@@ -122,16 +112,6 @@ fingerprintSourceRule =
       pure ([], Just fingerprint)
     where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
 
-getFileExistsRule :: VFSHandle -> Rules ()
-getFileExistsRule vfs =
-    defineEarlyCutoff $ \GetFileExists file -> do
-        alwaysRerun
-        res <- liftIO $ handle (\(_ :: IOException) -> return False) $
-            (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
-            Dir.doesFileExist (fromNormalizedFilePath file)
-        return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
-
-
 getModificationTimeRule :: VFSHandle -> Rules ()
 getModificationTimeRule vfs =
     defineEarlyCutoff $ \GetModificationTime file -> do
@@ -154,6 +134,8 @@ getModificationTimeRule vfs =
     -- time spent checking file modifications (which happens on every change)
     -- from > 0.5s to ~0.15s.
     -- We might also want to try speeding this up on Windows at some point.
+    -- TODO leverage DidChangeWatchedFile lsp notifications on clients that
+    -- support them, as done for GetFileExists
     getModTime :: FilePath -> IO BS.ByteString
     getModTime f =
 #ifdef mingw32_HOST_OS
@@ -198,20 +180,11 @@ ideTryIOException fp act =
 getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)
 getFileContents = use_ GetFileContents
 
-getFileExists :: NormalizedFilePath -> Action Bool
-getFileExists =
-    -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
-    -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
-    -- cached 'No' rather than an exception in the wrong place
-    use_ GetFileExists
-
-
 fileStoreRules :: VFSHandle -> Rules ()
 fileStoreRules vfs = do
     addIdeGlobal vfs
     getModificationTimeRule vfs
     getFileContentsRule vfs
-    getFileExistsRule vfs
     fingerprintSourceRule
 
 

src/Development/IDE/Core/Rules.hs

@@ -37,7 +37,8 @@ import Development.IDE.Types.Options
 import Development.IDE.Spans.Calculate
 import Development.IDE.Import.DependencyInformation
 import Development.IDE.Import.FindImports
-import           Development.IDE.Core.FileStore
+import           Development.IDE.Core.FileExists
+import           Development.IDE.Core.FileStore        (getFileContents, getSourceFingerprint)
 import           Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.GHC.Util

src/Development/IDE/Core/Service.hs

@@ -23,13 +23,15 @@ import           Control.Concurrent.Async
 import Data.Maybe
 import Development.IDE.Types.Options (IdeOptions(..))
 import Control.Monad
-import           Development.IDE.Core.FileStore
+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.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
 
 import           Development.IDE.Core.Shake
 
@@ -42,14 +44,15 @@ instance IsIdeGlobal GlobalIdeOptions
 -- Exposed API
 
 -- | Initialise the Compiler Service.
-initialise :: Rules ()
+initialise :: LSP.ClientCapabilities
+           -> Rules ()
            -> IO LSP.LspId
            -> (LSP.FromServerMessage -> IO ())
            -> Logger
            -> IdeOptions
            -> VFSHandle
            -> IO IdeState
-initialise mainRule getLspId toDiags logger options vfs =
+initialise caps mainRule getLspId toDiags logger options vfs =
     shakeOpen
         getLspId
         toDiags
@@ -63,6 +66,7 @@ initialise mainRule getLspId toDiags logger options vfs =
             addIdeGlobal $ GlobalIdeOptions options
             fileStoreRules vfs
             ofInterestRules
+            fileExistsRules getLspId caps vfs
             mainRule
 
 writeProfile :: IdeState -> FilePath -> IO ()

src/Development/IDE/Core/Shake.hs

@@ -20,6 +20,7 @@
 --   between runs. To deserialise a Shake value, we just consult Values.
 module Development.IDE.Core.Shake(
     IdeState,
+    ShakeExtras(..), getShakeExtras,
     IdeRule, IdeResult, GetModificationTime(..),
     shakeOpen, shakeShut,
     shakeRun,
@@ -38,7 +39,8 @@ module Development.IDE.Core.Shake(
     FileVersion(..),
     Priority(..),
     updatePositionMapping,
-    OnDiskRule(..)
+    deleteValue,
+    OnDiskRule(..),
     ) where
 
 import           Development.Shake hiding (ShakeValue, doesFileExist)
@@ -257,6 +259,16 @@ setValues state key file val = modifyVar_ state $ \vals -> do
     -- Force to make sure the old HashMap is not retained
     evaluate $ HMap.insert (file, Key key) (fmap toDyn val) vals
 
+-- | Delete the value stored for a given ide build key
+deleteValue
+  :: (Typeable k, Hashable k, Eq k, Show k)
+  => IdeState
+  -> k
+  -> NormalizedFilePath
+  -> IO ()
+deleteValue IdeState{shakeExtras = ShakeExtras{state}} key file = modifyVar_ state $ \vals ->
+    evaluate $ HMap.delete (file, Key key) vals
+
 -- | We return Nothing if the rule has not run and Just Failed if it has failed to produce a value.
 getValues :: forall k v. IdeRule k v => Var Values -> k -> NormalizedFilePath -> IO (Maybe (Value v))
 getValues state key file = do

src/Development/IDE/LSP/Notifications.hs

@@ -2,26 +2,30 @@
 -- SPDX-License-Identifier: Apache-2.0
 
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RankNTypes            #-}
 
 module Development.IDE.LSP.Notifications
     ( setHandlersNotifications
     ) where
 
-import           Language.Haskell.LSP.Types
 import           Development.IDE.LSP.Server
-import qualified Language.Haskell.LSP.Core as LSP
+import qualified Language.Haskell.LSP.Core        as LSP
-import qualified Language.Haskell.LSP.Types as LSP
+import           Language.Haskell.LSP.Types
+import qualified Language.Haskell.LSP.Types       as LSP
 
-import Development.IDE.Types.Logger
+import           Development.IDE.Core.Service
-import Development.IDE.Core.Service
+import           Development.IDE.Types.Location
-import Development.IDE.Types.Location
+import           Development.IDE.Types.Logger
 
-import Control.Monad.Extra
+import           Control.Monad.Extra
-import qualified Data.Set                                  as S
+import           Data.Foldable                    as F
+import           Data.Maybe
+import qualified Data.Set                         as S
+import qualified Data.Text                        as Text
 
-import Development.IDE.Core.FileStore
+import           Development.IDE.Core.FileStore   (setSomethingModified)
-import Development.IDE.Core.OfInterest
+import           Development.IDE.Core.FileExists  (modifyFileExists)
+import           Development.IDE.Core.OfInterest
 
 
 whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO ()
@@ -52,4 +56,17 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x
             whenUriFile _uri $ \file -> do
                 modifyFilesOfInterest ide (S.delete file)
                 logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri
-    }
+    ,LSP.didChangeWatchedFilesNotificationHandler = withNotification (LSP.didChangeWatchedFilesNotificationHandler x) $
+        \_ ide (DidChangeWatchedFilesParams fileEvents) -> do
+            let events =
+                    mapMaybe
+                        (\(FileEvent uri ev) ->
+                            (, ev /= FcDeleted) . toNormalizedFilePath
+                            <$> LSP.uriToFilePath uri
+                        )
+                        ( F.toList fileEvents )
+            let msg = Text.pack $ show events
+            logInfo (ideLogger ide) $ "Files created or deleted: " <> msg
+            modifyFileExists ide events
+            setSomethingModified ide
+    }

test/exe/Main.hs

@@ -20,7 +20,8 @@ import qualified Data.Text as T
 import Development.IDE.Test
 import Development.IDE.Test.Runfiles
 import Development.IDE.Types.Location
-import Language.Haskell.LSP.Test
+import qualified Language.Haskell.LSP.Test as LSPTest
+import Language.Haskell.LSP.Test hiding (openDoc')
 import Language.Haskell.LSP.Types
 import Language.Haskell.LSP.Types.Capabilities
 import System.Environment.Blank (setEnv)
@@ -1583,7 +1584,8 @@ run s = withTempDir $ \dir -> do
   -- HIE calls getXgdDirectory which assumes that HOME is set.
   -- Only sets HOME if it wasn't already set.
   setEnv "HOME" "/homeless-shelter" False
-  runSessionWithConfig conf cmd fullCaps { _window = Just $ WindowClientCapabilities $ Just True } dir s
+  let lspTestCaps = fullCaps { _window = Just $ WindowClientCapabilities $ Just True }
+  runSessionWithConfig conf cmd lspTestCaps dir s
   where
     conf = defaultConfig
       -- If you uncomment this you can see all logging
@@ -1626,3 +1628,10 @@ unitTests = do
      [ testCase "empty file path" $
          uriToFilePath' (fromNormalizedUri $ filePathToUri' "") @?= Just ""
      ]
+
+-- | Wrapper around 'LSPTest.openDoc'' that sends file creation events
+openDoc' :: FilePath -> String -> T.Text -> Session TextDocumentIdentifier
+openDoc' fp name contents = do
+  res@(TextDocumentIdentifier uri) <- LSPTest.openDoc' fp name contents
+  sendNotification WorkspaceDidChangeWatchedFiles (DidChangeWatchedFilesParams $ List [FileEvent uri FcCreated])
+  return res