Skip to content

Commit 4cd1bb3

Browse files
pepeiborrapepeiborra
committed
WIP work with TH dependent files
1 parent dcd6816 commit 4cd1bb3

5 files changed

Lines changed: 127 additions & 87 deletions

File tree

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

Lines changed: 4 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -25,9 +25,9 @@ import Development.IDE.Core.Shake
2525
import Development.IDE.Graph
2626
import Development.IDE.Types.Location
2727
import Development.IDE.Types.Options
28+
import Ide.Plugin.Config (Config)
2829
import Language.LSP.Server hiding (getVirtualFile)
2930
import Language.LSP.Types
30-
import Language.LSP.Types.Capabilities
3131
import qualified System.Directory as Dir
3232
import qualified System.FilePath.Glob as Glob
3333

@@ -153,18 +153,11 @@ allExtensions opts = [extIncBoot | ext <- optExtensions opts, extIncBoot <- [ext
153153
-- | Installs the 'getFileExists' rules.
154154
-- Provides a fast implementation if client supports dynamic watched files.
155155
-- Creates a global state as a side effect in that case.
156-
fileExistsRules :: Maybe (LanguageContextEnv c) -> VFSHandle -> Rules ()
156+
fileExistsRules :: Maybe (LanguageContextEnv Config) -> VFSHandle -> Rules ()
157157
fileExistsRules lspEnv vfs = do
158158
supportsWatchedFiles <- case lspEnv of
159-
Just lspEnv' -> liftIO $ runLspT lspEnv' $ do
160-
ClientCapabilities {_workspace} <- getClientCapabilities
161-
case () of
162-
_ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
163-
, Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
164-
, Just True <- _dynamicRegistration
165-
-> pure True
166-
_ -> pure False
167-
Nothing -> pure False
159+
Nothing -> pure False
160+
Just lspEnv' -> liftIO $ runLspT lspEnv' isWatchSupported
168161
-- Create the global always, although it should only be used if we have fast rules.
169162
-- But there's a chance someone will send unexpected notifications anyway,
170163
-- e.g. https://github.com/haskell/ghcide/issues/599

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

Lines changed: 95 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -19,7 +19,9 @@ module Development.IDE.Core.FileStore(
1919
getModificationTimeImpl,
2020
addIdeGlobal,
2121
getFileContentsImpl,
22-
getModTime
22+
getModTime,
23+
isWatchSupported,
24+
registerFileWatches
2325
) where
2426

2527
import Control.Concurrent.STM (atomically)
@@ -48,7 +50,8 @@ import Development.IDE.Types.Location
4850
import Development.IDE.Types.Options
4951
import Development.IDE.Types.Shake (SomeShakeValue)
5052
import HieDb.Create (deleteMissingRealFiles)
51-
import Ide.Plugin.Config (CheckParents (..))
53+
import Ide.Plugin.Config (CheckParents (..),
54+
Config)
5255
import System.IO.Error
5356

5457
#ifdef mingw32_HOST_OS
@@ -65,13 +68,20 @@ import qualified Data.ByteString.Lazy as LBS
6568
import qualified Data.HashSet as HSet
6669
import Data.IORef.Extra (atomicModifyIORef_)
6770
import Data.List (foldl')
71+
import qualified Data.Text as Text
6872
import Language.LSP.Server hiding
6973
(getVirtualFile)
7074
import qualified Language.LSP.Server as LSP
71-
import Language.LSP.Types (FileChangeType (FcChanged),
75+
import Language.LSP.Types (DidChangeWatchedFilesRegistrationOptions (DidChangeWatchedFilesRegistrationOptions),
76+
FileChangeType (FcChanged),
7277
FileEvent (FileEvent),
78+
FileSystemWatcher (..),
79+
WatchKind (..),
80+
_watchers,
7381
toNormalizedFilePath,
7482
uriToFilePath)
83+
import qualified Language.LSP.Types as LSP
84+
import qualified Language.LSP.Types.Capabilities as LSP
7585
import Language.LSP.VFS
7686
import System.FilePath
7787

@@ -96,46 +106,54 @@ makeLSPVFSHandle lspEnv = VFSHandle
96106
, setVirtualFileContents = Nothing
97107
}
98108

109+
addWatchedFileRule :: (NormalizedFilePath -> Action Bool) -> Rules ()
110+
addWatchedFileRule isWatched = defineNoDiagnostics $ \AddWatchedFile f -> do
111+
isAlreadyWatched <- isWatched f
112+
if isAlreadyWatched then pure (Just True) else do
113+
ShakeExtras{lspEnv} <- getShakeExtras
114+
case lspEnv of
115+
Just env -> fmap Just $ liftIO $ LSP.runLspT env $
116+
registerFileWatches [fromNormalizedFilePath f]
117+
Nothing -> pure Nothing
99118

100-
getModificationTimeRule :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
101-
getModificationTimeRule vfs isWatched = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
102-
getModificationTimeImpl vfs isWatched missingFileDiags file
119+
getModificationTimeRule :: VFSHandle -> Rules ()
120+
getModificationTimeRule vfs = defineEarlyCutoff $ Rule $ \(GetModificationTime_ missingFileDiags) file ->
121+
getModificationTimeImpl vfs missingFileDiags file
103122

104123
getModificationTimeImpl :: VFSHandle
105-
-> (NormalizedFilePath -> Action Bool)
106124
-> Bool
107125
-> NormalizedFilePath
108126
-> Action
109127
(Maybe BS.ByteString, ([FileDiagnostic], Maybe FileVersion))
110-
getModificationTimeImpl vfs isWatched missingFileDiags file = do
111-
let file' = fromNormalizedFilePath file
112-
let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
113-
mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
114-
case mbVirtual of
115-
Just (virtualFileVersion -> ver) -> do
116-
alwaysRerun
117-
pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))
118-
Nothing -> do
119-
isWF <- isWatched file
120-
if isWF
121-
then -- the file is watched so we can rely on FileWatched notifications,
122-
-- but also need a dependency on IsFileOfInterest to reinstall
123-
-- alwaysRerun when the file becomes VFS
124-
void (use_ IsFileOfInterest file)
125-
else if isInterface file
126-
then -- interface files are tracked specially using the closed world assumption
127-
pure ()
128-
else -- in all other cases we will need to freshly check the file system
129-
alwaysRerun
128+
getModificationTimeImpl vfs missingFileDiags file = do
129+
let file' = fromNormalizedFilePath file
130+
let wrap time = (Just $ LBS.toStrict $ B.encode $ toRational time, ([], Just $ ModificationTime time))
131+
mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
132+
case mbVirtual of
133+
Just (virtualFileVersion -> ver) -> do
134+
alwaysRerun
135+
pure (Just $ LBS.toStrict $ B.encode ver, ([], Just $ VFSVersion ver))
136+
Nothing -> do
137+
isWF <- use_ AddWatchedFile file
138+
if isWF
139+
then -- the file is watched so we can rely on FileWatched notifications,
140+
-- but also need a dependency on IsFileOfInterest to reinstall
141+
-- alwaysRerun when the file becomes VFS
142+
void (use_ IsFileOfInterest file)
143+
else if isInterface file
144+
then -- interface files are tracked specially using the closed world assumption
145+
pure ()
146+
else -- in all other cases we will need to freshly check the file system
147+
alwaysRerun
130148

131-
liftIO $ fmap wrap (getModTime file')
132-
`catch` \(e :: IOException) -> do
133-
let err | isDoesNotExistError e = "File does not exist: " ++ file'
134-
| otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
135-
diag = ideErrorText file (T.pack err)
136-
if isDoesNotExistError e && not missingFileDiags
137-
then return (Nothing, ([], Nothing))
138-
else return (Nothing, ([diag], Nothing))
149+
liftIO $ fmap wrap (getModTime file')
150+
`catch` \(e :: IOException) -> do
151+
let err | isDoesNotExistError e = "File does not exist: " ++ file'
152+
| otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
153+
diag = ideErrorText file (T.pack err)
154+
if isDoesNotExistError e && not missingFileDiags
155+
then return (Nothing, ([], Nothing))
156+
else return (Nothing, ([diag], Nothing))
139157

140158
-- | Interface files cannot be watched, since they live outside the workspace.
141159
-- But interface files are private, in that only HLS writes them.
@@ -229,8 +247,9 @@ getFileContents f = do
229247
fileStoreRules :: VFSHandle -> (NormalizedFilePath -> Action Bool) -> Rules ()
230248
fileStoreRules vfs isWatched = do
231249
addIdeGlobal vfs
232-
getModificationTimeRule vfs isWatched
250+
getModificationTimeRule vfs
233251
getFileContentsRule vfs
252+
addWatchedFileRule isWatched
234253

235254
-- | Note that some buffer for a specific file has been modified but not
236255
-- with what changes.
@@ -283,3 +302,43 @@ setSomethingModified state keys = do
283302
atomicModifyIORef_ (dirtyKeys $ shakeExtras state) $ \x ->
284303
foldl' (flip HSet.insert) x keys
285304
void $ restartShakeSession (shakeExtras state) []
305+
306+
registerFileWatches :: [String] -> LSP.LspT Config IO Bool
307+
registerFileWatches globs = do
308+
watchSupported <- isWatchSupported
309+
if watchSupported
310+
then do
311+
let
312+
regParams = LSP.RegistrationParams (List [LSP.SomeRegistration registration])
313+
-- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
314+
-- We could also use something like a random UUID, as some other servers do, but this works for
315+
-- our purposes.
316+
registration = LSP.Registration "globalFileWatches"
317+
LSP.SWorkspaceDidChangeWatchedFiles
318+
regOptions
319+
regOptions =
320+
DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }
321+
-- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
322+
watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}
323+
-- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
324+
-- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
325+
-- followed by a file with an extension 'hs'.
326+
watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }
327+
-- We use multiple watchers instead of one using '{}' because lsp-test doesn't
328+
-- support that: https://github.com/bubba/lsp-test/issues/77
329+
watchers = [ watcher (Text.pack glob) | glob <- globs ]
330+
331+
void $ LSP.sendRequest LSP.SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response
332+
return True
333+
else return False
334+
335+
isWatchSupported :: LSP.LspT Config IO Bool
336+
isWatchSupported = do
337+
clientCapabilities <- LSP.getClientCapabilities
338+
pure $ case () of
339+
_ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
340+
, Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
341+
, Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
342+
, Just True <- _dynamicRegistration
343+
-> True
344+
| otherwise -> False

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

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -266,6 +266,8 @@ type instance RuleResult GetFileContents = (FileVersion, Maybe Text)
266266

267267
type instance RuleResult GetFileExists = Bool
268268

269+
type instance RuleResult AddWatchedFile = Bool
270+
269271

270272
-- The Shake key type for getModificationTime queries
271273
newtype GetModificationTime = GetModificationTime_
@@ -490,6 +492,12 @@ instance Binary GetClientSettings
490492

491493
type instance RuleResult GetClientSettings = Hashed (Maybe Value)
492494

495+
data AddWatchedFile = AddWatchedFile deriving (Eq, Show, Typeable, Generic)
496+
instance Hashable AddWatchedFile
497+
instance NFData AddWatchedFile
498+
instance Binary AddWatchedFile
499+
500+
493501
-- A local rule type to get caching. We want to use newCache, but it has
494502
-- thread killed exception issues, so we lift it to a full rule.
495503
-- https://github.com/digital-asset/daml/pull/2808#issuecomment-529639547

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

Lines changed: 12 additions & 36 deletions
Original file line numberDiff line numberDiff line change
@@ -11,10 +11,8 @@ module Development.IDE.LSP.Notifications
1111
, descriptor
1212
) where
1313

14-
import qualified Language.LSP.Server as LSP
1514
import Language.LSP.Types
1615
import qualified Language.LSP.Types as LSP
17-
import qualified Language.LSP.Types.Capabilities as LSP
1816

1917
import Development.IDE.Core.IdeConfiguration
2018
import Development.IDE.Core.Service
@@ -30,7 +28,8 @@ import qualified Data.Text as Text
3028
import Control.Monad.IO.Class
3129
import Development.IDE.Core.FileExists (modifyFileExists,
3230
watchedGlobs)
33-
import Development.IDE.Core.FileStore (resetFileStore,
31+
import Development.IDE.Core.FileStore (registerFileWatches,
32+
resetFileStore,
3433
setFileModified,
3534
setSomethingModified,
3635
typecheckParents)
@@ -109,38 +108,15 @@ descriptor plId = (defaultPluginDescriptor plId) { pluginNotificationHandlers =
109108
liftIO $ shakeSessionInit ide
110109

111110
--------- Set up file watchers ------------------------------------------------------------------------
112-
clientCapabilities <- LSP.getClientCapabilities
113-
let watchSupported = case () of
114-
_ | LSP.ClientCapabilities{_workspace} <- clientCapabilities
115-
, Just LSP.WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
116-
, Just LSP.DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
117-
, Just True <- _dynamicRegistration
118-
-> True
119-
| otherwise -> False
120-
if watchSupported
121-
then do
122-
opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
123-
let
124-
regParams = RegistrationParams (List [SomeRegistration registration])
125-
-- The registration ID is arbitrary and is only used in case we want to deregister (which we won't).
126-
-- We could also use something like a random UUID, as some other servers do, but this works for
127-
-- our purposes.
128-
registration = Registration "globalFileWatches"
129-
SWorkspaceDidChangeWatchedFiles
130-
regOptions
131-
regOptions =
132-
DidChangeWatchedFilesRegistrationOptions { _watchers = List watchers }
133-
-- See Note [File existence cache and LSP file watchers] for why this exists, and the choice of watch kind
134-
watchKind = WatchKind { _watchCreate = True, _watchChange = True, _watchDelete = True}
135-
-- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
136-
-- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
137-
-- followed by a file with an extension 'hs'.
138-
watcher glob = FileSystemWatcher { _globPattern = glob, _kind = Just watchKind }
139-
-- We use multiple watchers instead of one using '{}' because lsp-test doesn't
140-
-- support that: https://github.com/bubba/lsp-test/issues/77
141-
watchers = [ watcher (Text.pack glob) | glob <- watchedGlobs opts ]
142-
143-
void $ LSP.sendRequest SClientRegisterCapability regParams (const $ pure ()) -- TODO handle response
144-
else liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
111+
opts <- liftIO $ getIdeOptionsIO $ shakeExtras ide
112+
-- See Note [Which files should we watch?] for an explanation of why the pattern is the way that it is
113+
-- The patterns will be something like "**/.hs", i.e. "any number of directory segments,
114+
-- followed by a file with an extension 'hs'.
115+
-- We use multiple watchers instead of one using '{}' because lsp-test doesn't
116+
-- support that: https://github.com/bubba/lsp-test/issues/77
117+
let globs = watchedGlobs opts
118+
success <- registerFileWatches globs
119+
unless success $
120+
liftIO $ logDebug (ideLogger ide) "Warning: Client does not support watched files. Falling back to OS polling"
145121
]
146122
}

‎ghcide/test/exe/Main.hs‎

Lines changed: 8 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -4733,7 +4733,8 @@ dependentFileTest = testGroup "addDependentFile"
47334733
test dir = do
47344734
-- If the file contains B then no type error
47354735
-- otherwise type error
4736-
liftIO $ writeFile (dir </> "dep-file.txt") "A"
4736+
let depFilePath = dir </> "dep-file.txt"
4737+
liftIO $ writeFile depFilePath "A"
47374738
let fooContent = T.unlines
47384739
[ "{-# LANGUAGE TemplateHaskell #-}"
47394740
, "module Foo where"
@@ -4745,18 +4746,21 @@ dependentFileTest = testGroup "addDependentFile"
47454746
, " if f == \"B\" then [| 1 |] else lift f)"
47464747
]
47474748
let bazContent = T.unlines ["module Baz where", "import Foo ()"]
4748-
_ <-createDoc "Foo.hs" "haskell" fooContent
4749+
_ <- createDoc "Foo.hs" "haskell" fooContent
47494750
doc <- createDoc "Baz.hs" "haskell" bazContent
47504751
expectDiagnostics
47514752
[("Foo.hs", [(DsError, (4, 6), "Couldn't match expected type")])]
47524753
-- Now modify the dependent file
4753-
liftIO $ writeFile (dir </> "dep-file.txt") "B"
4754+
liftIO $ writeFile depFilePath "B"
4755+
sendNotification SWorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams $
4756+
List [FileEvent (filePathToUri depFilePath) FcChanged ]
4757+
4758+
-- Modifying Baz will now trigger Foo to be rebuilt as well
47544759
let change = TextDocumentContentChangeEvent
47554760
{ _range = Just (Range (Position 2 0) (Position 2 6))
47564761
, _rangeLength = Nothing
47574762
, _text = "f = ()"
47584763
}
4759-
-- Modifying Baz will now trigger Foo to be rebuilt as well
47604764
changeDoc doc [change]
47614765
expectDiagnostics [("Foo.hs", [])]
47624766

0 commit comments

Comments
 (0)