From d8480ac59acea0519cf3da0f4a7748cf720f91c0 Mon Sep 17 00:00:00 2001 From: Pepe Iborra Date: Sun, 30 May 2021 09:39:02 +0100 Subject: [PATCH] WIP work with TH dependent files --- ghcide/src/Development/IDE/Core/RuleTypes.hs | 8 +++ ghcide/src/Development/IDE/Core/Rules.hs | 11 +++++ .../src/Development/IDE/LSP/Notifications.hs | 49 +++++++++++++------ ghcide/test/exe/Main.hs | 12 +++-- 4 files changed, 61 insertions(+), 19 deletions(-) diff --git a/ghcide/src/Development/IDE/Core/RuleTypes.hs b/ghcide/src/Development/IDE/Core/RuleTypes.hs index 228a063cea1..0b19fc85a47 100644 --- a/ghcide/src/Development/IDE/Core/RuleTypes.hs +++ b/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 diff --git a/ghcide/src/Development/IDE/Core/Rules.hs b/ghcide/src/Development/IDE/Core/Rules.hs index 6240eada6bd..1b4f77d09d7 100644 --- a/ghcide/src/Development/IDE/Core/Rules.hs +++ b/ghcide/src/Development/IDE/Core/Rules.hs @@ -151,6 +151,7 @@ import Ide.Plugin.Properties (HasProperty, import Ide.PluginUtils (configForPlugin) import Ide.Types (DynFlagsModifications (dynFlagsModifyGlobal, dynFlagsModifyParser), PluginId) +import Development.IDE.LSP.Notifications (registerFileWatches) -- | This is useful for rules to convert rules that can only produce errors or -- a result into the more general IdeResult type that supports producing @@ -628,6 +629,7 @@ typeCheckRuleDefinition hsc pm = do r@(_, mtc) <- a forM_ mtc $ \tc -> do used_files <- liftIO $ readIORef $ tcg_dependent_files $ tmrTypechecked tc + void $ uses_ AddWatchedFile (map toNormalizedFilePath' used_files) void $ uses_ GetModificationTime (map toNormalizedFilePath' used_files) return r @@ -1034,6 +1036,14 @@ writeHiFileAction hsc hiFile = do resetInterfaceStore extras $ toNormalizedFilePath' targetPath writeHiFile hsc hiFile +addWatchedFileRule :: Rules () +addWatchedFileRule = defineNoDiagnostics $ \AddWatchedFile f -> do + ShakeExtras{lspEnv} <- getShakeExtras + case lspEnv of + Just env -> fmap Just $ liftIO $ LSP.runLspT env $ + registerFileWatches [fromNormalizedFilePath f] + Nothing -> pure Nothing + -- | A rule that wires per-file rules together mainRule :: Rules () mainRule = do @@ -1066,6 +1076,7 @@ mainRule = do persistentHieFileRule persistentDocMapRule persistentImportMapRule + addWatchedFileRule -- | Given the path to a module src file, this rule returns True if the -- corresponding `.hi` file is stable, that is, if it is newer diff --git a/ghcide/src/Development/IDE/LSP/Notifications.hs b/ghcide/src/Development/IDE/LSP/Notifications.hs index 087a2100183..41188e2a83e 100644 --- a/ghcide/src/Development/IDE/LSP/Notifications.hs +++ b/ghcide/src/Development/IDE/LSP/Notifications.hs @@ -9,7 +9,8 @@ module Development.IDE.LSP.Notifications ( whenUriFile , descriptor - ) where + , isWatchSupported + ,registerFileWatches) where import qualified Language.LSP.Server as LSP import Language.LSP.Types @@ -37,7 +38,8 @@ import Development.IDE.Core.FileStore (resetFileStore, import Development.IDE.Core.OfInterest import Development.IDE.Core.RuleTypes (GetClientSettings (..)) import Development.IDE.Types.Shake (toKey) -import Ide.Plugin.Config (CheckParents (CheckOnClose)) +import Ide.Plugin.Config (CheckParents (CheckOnClose), + Config) import Ide.Types whenUriFile :: Uri -> (NormalizedFilePath -> IO ()) -> IO () @@ -109,17 +111,24 @@ 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 + 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" + ] + } + +registerFileWatches :: [String] -> LSP.LspT Config IO Bool +registerFileWatches globs = do + watchSupported <- isWatchSupported 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). @@ -138,9 +147,19 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers = 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 ] + watchers = [ watcher (Text.pack glob) | glob <- globs ] 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" - ] - } + 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 diff --git a/ghcide/test/exe/Main.hs b/ghcide/test/exe/Main.hs index e8f8a8bceee..b22fbf424f2 100644 --- a/ghcide/test/exe/Main.hs +++ b/ghcide/test/exe/Main.hs @@ -4733,7 +4733,8 @@ dependentFileTest = testGroup "addDependentFile" test dir = do -- If the file contains B then no type error -- otherwise type error - liftIO $ writeFile (dir "dep-file.txt") "A" + let depFilePath = dir "dep-file.txt" + liftIO $ writeFile depFilePath "A" let fooContent = T.unlines [ "{-# LANGUAGE TemplateHaskell #-}" , "module Foo where" @@ -4745,18 +4746,21 @@ dependentFileTest = testGroup "addDependentFile" , " if f == \"B\" then [| 1 |] else lift f)" ] let bazContent = T.unlines ["module Baz where", "import Foo ()"] - _ <-createDoc "Foo.hs" "haskell" fooContent + _ <- createDoc "Foo.hs" "haskell" fooContent doc <- createDoc "Baz.hs" "haskell" bazContent expectDiagnostics [("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])] -- Now modify the dependent file - liftIO $ writeFile (dir "dep-file.txt") "B" + liftIO $ writeFile depFilePath "B" + sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $ + List [FileEvent (filePathToUri depFilePath) FcChanged ] + + -- Modifying Baz will now trigger Foo to be rebuilt as well let change = TextDocumentContentChangeEvent { _range = Just (Range (Position 2 0) (Position 2 6)) , _rangeLength = Nothing , _text = "f = ()" } - -- Modifying Baz will now trigger Foo to be rebuilt as well changeDoc doc [change] expectDiagnostics [("Foo.hs", [])]