Fix performance of getFileExists

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
@@ -221,4 +222,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,172 @@
+{-# 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.Lazy          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
+
+  -- Mask to ensure that the previous values are flushed together with the map update
+  mask $ \_ -> do
+    modifyVar_ var $ evaluate . Map.union changesMap
+    let flushPreviousValues = do
+          ShakeExtras { state } <- getShakeExtras
+          liftIO $ mapM_ (deleteValue state GetFileExists . fst) changes
+    void $ shakeRun state [flushPreviousValues]
+
+-------------------------------------------------------------------------------------
+
+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
+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 (createKey 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
+          unless (Map.member file x) (addListener eventer file)
+          return x
+
+        pure (createKey exist, ([], Just exist))
+ where
+  createKey = Just . BS.toStrict . encode
+  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
+                                  }
+
+    void $ eventer $ ReqRegisterCapability req
+
+fileExistsRulesSlow:: VFSHandle -> Rules ()
+fileExistsRulesSlow vfs = do
+  defineEarlyCutoff $ \GetFileExists file -> do
+    alwaysRerun
+    exist <- liftIO $ getFileExistsVFS vfs file
+    pure (Just $ BS.toStrict $ encode 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
@@ -122,16 +121,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 +143,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 +189,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)
+  => Var Values
+  -> k
+  -> NormalizedFilePath
+  -> IO ()
+deleteValue 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