Use file watches for all workspace files

ghcide/src/Development/IDE/Core/FileExists.hs

@@ -17,6 +17,7 @@ import           Control.Monad.IO.Class
 import qualified Data.ByteString                       as BS
 import           Data.HashMap.Strict                   (HashMap)
 import qualified Data.HashMap.Strict                   as HashMap
+import           Data.List                             (partition)
 import           Data.Maybe
 import           Development.IDE.Core.FileStore
 import           Development.IDE.Core.IdeConfiguration
@@ -25,9 +26,9 @@ import           Development.IDE.Core.Shake
 import           Development.IDE.Graph
 import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
+import           Ide.Plugin.Config                     (Config)
 import           Language.LSP.Server                   hiding (getVirtualFile)
 import           Language.LSP.Types
-import           Language.LSP.Types.Capabilities
 import qualified System.Directory                      as Dir
 import qualified System.FilePath.Glob                  as Glob
 
@@ -91,22 +92,25 @@ modifyFileExists :: IdeState -> [FileEvent] -> IO ()
 modifyFileExists state changes = do
   FileExistsMapVar var <- getIdeGlobalState state
   changesMap           <- evaluate $ HashMap.fromList $
-    [ (toNormalizedFilePath' f, newState)
+    [ (toNormalizedFilePath' f, change)
     | FileEvent uri change <- changes
     , Just f <- [uriToFilePath uri]
-    , Just newState <- [fromChange change]
     ]
   -- Masked to ensure that the previous values are flushed together with the map update
   mask $ \_ -> do
     -- update the map
-    void $ modifyVar' var $ HashMap.union changesMap
+    void $ modifyVar' var $ HashMap.union (HashMap.mapMaybe fromChange changesMap)
     -- See Note [Invalidating file existence results]
     -- flush previous values
     mapM_ (deleteValue (shakeExtras state) GetFileExists) (HashMap.keys changesMap)
+    let (fileModifChanges, fileExistChanges) =
+            partition ((== FcChanged) . snd) (HashMap.toList changesMap)
+    recordDirtyKeys (shakeExtras state) GetFileExists $ map fst fileExistChanges
+    recordDirtyKeys (shakeExtras state) GetModificationTime $ map fst fileModifChanges
 
 fromChange :: FileChangeType -> Maybe Bool
 fromChange FcCreated = Just True
-fromChange FcDeleted = Just True
+fromChange FcDeleted = Just False
 fromChange FcChanged = Nothing
 
 -------------------------------------------------------------------------------------
@@ -153,18 +157,11 @@ allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext
 -- | 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 :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules ()
+fileExistsRules :: Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules ()
 fileExistsRules lspEnv vfs = do
   supportsWatchedFiles <- case lspEnv of
-    Just lspEnv' -> liftIO $ runLspT lspEnv' $ do
-      ClientCapabilities {_workspace} <- getClientCapabilities
-      case () of
-        _ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
-          , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
-          , Just True <- _dynamicRegistration
-          -> pure True
-        _ -> pure False
-    Nothing -> pure False
+    Nothing      -> pure False
+    Just lspEnv' -> liftIO $  runLspT lspEnv' isWatchSupported
   -- Create the global always, although it should only be used if we have fast rules.
   -- But there's a chance someone will send unexpected notifications anyway,
   -- e.g. https://github.com/haskell/ghcide/issues/599

ghcide/src/Development/IDE/Core/FileStore.hs

@@ -19,7 +19,9 @@ module Development.IDE.Core.FileStore(
     getModificationTimeImpl,
     addIdeGlobal,
     getFileContentsImpl,
-    getModTime
+    getModTime,
+    isWatchSupported,
+    registerFileWatches
     ) where
 
 import           Control.Concurrent.STM                       (atomically)
@@ -48,7 +50,8 @@ import           Development.IDE.Types.Location
 import           Development.IDE.Types.Options
 import           Development.IDE.Types.Shake                  (SomeShakeValue)
 import           HieDb.Create                                 (deleteMissingRealFiles)
-import           Ide.Plugin.Config                            (CheckParents (..))
+import           Ide.Plugin.Config                            (CheckParents (..),
+                                                               Config)
 import           System.IO.Error
 
 #ifdef mingw32_HOST_OS
@@ -65,13 +68,20 @@ import qualified Data.ByteString.Lazy                         as LBS
 import qualified Data.HashSet                                 as HSet
 import           Data.IORef.Extra                             (atomicModifyIORef_)
 import           Data.List                                    (foldl')
+import qualified Data.Text                                    as Text
 import           Language.LSP.Server                          hiding
                                                               (getVirtualFile)
 import qualified Language.LSP.Server                          as LSP
-import           Language.LSP.Types                           (FileChangeType (FcChanged),
+import           Language.LSP.Types                           (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),
+                                                               FileChangeType (FcChanged),
                                                                FileEvent (FileEvent),
+                                                               FileSystemWatcher (..),
+                                                               WatchKind (..),
+                                                               _watchers,
                                                                toNormalizedFilePath,
                                                                uriToFilePath)
+import qualified Language.LSP.Types                           as LSP
+import qualified Language.LSP.Types.Capabilities              as LSP
 import           Language.LSP.VFS
 import           System.FilePath
 
@@ -96,46 +106,54 @@ makeLSPVFSHandle lspEnv = VFSHandle
     , setVirtualFileContents = Nothing
    }
 
+addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules ()
+addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do
+  isAlreadyWatched <- isWatched f
+  if isAlreadyWatched then pure (Just True) else do
+    ShakeExtras{lspEnv} <- getShakeExtras
+    case lspEnv of
+        Just env -> fmap Just $ liftIO $ LSP.runLspT env $
+            registerFileWatches [fromNormalizedFilePath f]
+        Nothing -> pure Nothing
 
-getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
-getModificationTimeRule vfs isWatched = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
-    getModificationTimeImpl vfs isWatched missingFileDiags file
+getModificationTimeRule :: VFSHandle -> Rules ()
+getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
+    getModificationTimeImpl vfs missingFileDiags file
 
 getModificationTimeImpl :: VFSHandle
-    -> (NormalizedFilePath -> Action Bool)
     -> Bool
     -> NormalizedFilePath
     -> Action
         (Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
-getModificationTimeImpl vfs isWatched missingFileDiags file = do
-        let file' = fromNormalizedFilePath file
-        let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
-        mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
-        case mbVirtual of
-            Just (virtualFileVersion -> ver) -> do
-                alwaysRerun
-                pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))
-            Nothing -> do
-                isWF <- isWatched file
-                if isWF
-                    then -- the file is watched so we can rely on FileWatched notifications,
-                         -- but also need a dependency on IsFileOfInterest to reinstall
-                         -- alwaysRerun when the file becomes VFS
-                        void (use_ IsFileOfInterest file)
-                    else if isInterface file
-                        then -- interface files are tracked specially using the closed world assumption
-                            pure ()
-                        else -- in all other cases we will need to freshly check the file system
-                            alwaysRerun
+getModificationTimeImpl vfs missingFileDiags file = do
+    let file' = fromNormalizedFilePath file
+    let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
+    mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
+    case mbVirtual of
+        Just (virtualFileVersion -> ver) -> do
+            alwaysRerun
+            pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))
+        Nothing -> do
+            isWF <- use_ AddWatchedFile file
+            if isWF
+                then -- the file is watched so we can rely on FileWatched notifications,
+                        -- but also need a dependency on IsFileOfInterest to reinstall
+                        -- alwaysRerun when the file becomes VFS
+                    void (use_ IsFileOfInterest file)
+                else if isInterface file
+                    then -- interface files are tracked specially using the closed world assumption
+                        pure ()
+                    else -- in all other cases we will need to freshly check the file system
+                        alwaysRerun
 
-                liftIO $ fmap wrap (getModTime file')
-                    `catch` \(e :: IOException) -> do
-                        let err | isDoesNotExistError e = "File does not exist: " ++ file'
-                                | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
-                            diag = ideErrorText file (T.pack err)
-                        if isDoesNotExistError e && not missingFileDiags
-                            then return (Nothing, ([], Nothing))
-                            else return (Nothing, ([diag], Nothing))
+            liftIO $ fmap wrap (getModTime file')
+                `catch` \(e :: IOException) -> do
+                    let err | isDoesNotExistError e = "File does not exist: " ++ file'
+                            | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
+                        diag = ideErrorText file (T.pack err)
+                    if isDoesNotExistError e && not missingFileDiags
+                        then return (Nothing, ([], Nothing))
+                        else return (Nothing, ([diag], Nothing))
 
 -- | Interface files cannot be watched, since they live outside the workspace.
 --   But interface files are private, in that only HLS writes them.
@@ -229,8 +247,9 @@ getFileContents f = do
 fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
 fileStoreRules vfs isWatched = do
     addIdeGlobal vfs
-    getModificationTimeRule vfs isWatched
+    getModificationTimeRule vfs
     getFileContentsRule vfs
+    addWatchedFileRule isWatched
 
 -- | Note that some buffer for a specific file has been modified but not
 -- with what changes.
@@ -283,3 +302,43 @@ setSomethingModified state keys = do
     atomicModifyIORef_ (dirtyKeys $ shakeExtras state) $ \x ->
         foldl' (flip HSet.insert) x keys
     void $ restartShakeSession (shakeExtras state) []
+
+registerFileWatches :: [String] -> LSP.LspT Config IO Bool
+registerFileWatches globs = do
+      watchSupported <- isWatchSupported
+      if watchSupported
+      then do
+        let
+          regParams    = LSP.RegistrationParams (List [LSP.SomeRegistration registration])
+          -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
+          -- We could also use something like a random UUID, as some other servers do, but this works for
+          -- our purposes.
+          registration = LSP.Registration "globalFileWatches"
+                                           LSP.SWorkspaceDidChangeWatchedFiles
+                                           regOptions
+          regOptions =
+            DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }
+          -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
+          watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}
+          -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
+          -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
+          -- followed by a file with an extension 'hs'.
+          watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }
+          -- We use multiple watchers instead of one using '{}' because lsp-test doesn't
+          -- support that: https://github.com/bubba/lsp-test/issues/77
+          watchers = [ watcher (Text.pack glob) | glob <- globs ]
+
+        void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response
+        return True
+      else return False
+
+isWatchSupported :: LSP.LspT Config IO Bool
+isWatchSupported = do
+      clientCapabilities <- LSP.getClientCapabilities
+      pure $ case () of
+            _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
+              , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
+              , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
+              , Just True <- _dynamicRegistration
+                -> True
+              | otherwise -> False

ghcide/src/Development/IDE/Core/RuleTypes.hs

@@ -266,6 +266,8 @@ type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
 
 type instance RuleResult GetFileExists = Bool
 
+type instance RuleResult AddWatchedFile = Bool
+
 
 -- The Shake key type for getModificationTime queries
 newtype GetModificationTime = GetModificationTime_
@@ -490,6 +492,12 @@ instance Binary   GetClientSettings
 
 type instance RuleResult GetClientSettings = Hashed (Maybe Value)
 
+data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic)
+instance Hashable AddWatchedFile
+instance NFData   AddWatchedFile
+instance Binary   AddWatchedFile
+
+
 -- A local rule type to get caching. We want to use newCache, but it has
 -- thread killed exception issues, so we lift it to a full rule.
 -- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547

ghcide/src/Development/IDE/LSP/Notifications.hs

@@ -11,10 +11,8 @@ module Development.IDE.LSP.Notifications
     , descriptor
     ) where
 
-import qualified Language.LSP.Server                   as LSP
 import           Language.LSP.Types
 import qualified Language.LSP.Types                    as LSP
-import qualified Language.LSP.Types.Capabilities       as LSP
 
 import           Development.IDE.Core.IdeConfiguration
 import           Development.IDE.Core.Service
@@ -30,7 +28,8 @@ import qualified Data.Text                             as Text
 import           Control.Monad.IO.Class
 import           Development.IDE.Core.FileExists       (modifyFileExists,
                                                         watchedGlobs)
-import           Development.IDE.Core.FileStore        (resetFileStore,
+import           Development.IDE.Core.FileStore        (registerFileWatches,
+                                                        resetFileStore,
                                                         setFileModified,
                                                         setSomethingModified,
                                                         typecheckParents)
@@ -109,38 +108,15 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers =
       liftIO $ shakeSessionInit ide
 
       --------- Set up file watchers ------------------------------------------------------------------------
-      clientCapabilities <- LSP.getClientCapabilities
-      let watchSupported = case () of
-            _ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
-              , Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
-              , Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
-              , Just True <- _dynamicRegistration
-                -> True
-              | otherwise -> False
-      if watchSupported
-      then do
-        opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
-        let
-          regParams    = RegistrationParams (List [SomeRegistration registration])
-          -- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
-          -- We could also use something like a random UUID, as some other servers do, but this works for
-          -- our purposes.
-          registration = Registration "globalFileWatches"
-                                      SWorkspaceDidChangeWatchedFiles
-                                      regOptions
-          regOptions =
-            DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }
-          -- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
-          watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}
-          -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
-          -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
-          -- followed by a file with an extension 'hs'.
-          watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }
-          -- We use multiple watchers instead of one using '{}' because lsp-test doesn't
-          -- support that: https://github.com/bubba/lsp-test/issues/77
-          watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ]
-
-        void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response
-      else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
+      opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
+        -- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
+        -- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
+        -- followed by a file with an extension 'hs'.
+        -- We use multiple watchers instead of one using '{}' because lsp-test doesn't
+        -- support that: https://github.com/bubba/lsp-test/issues/77
+      let globs = watchedGlobs opts
+      success <- registerFileWatches globs
+      unless success $
+        liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
   ]
     }