@@ -0,0 +1,187 @@
1+{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+module Development.IDE.Core.FileExists
11+import Control.Concurrent.Extra
12+import Control.Exception
13+import Control.Monad.Extra
14+import qualified Data.Aeson as A
16+import qualified Data.ByteString as BS
17+import Data.Map.Strict ( Map )
18+import qualified Data.Map.Strict as Map
20+import qualified Data.Text as T
21+import Development.IDE.Core.FileStore
22+import Development.IDE.Core.Shake
23+import Development.IDE.Types.Location
24+import Development.Shake
25+import Development.Shake.Classes
27+import Language.Haskell.LSP.Messages
28+import Language.Haskell.LSP.Types
29+import Language.Haskell.LSP.Types.Capabilities
30+import qualified System.Directory as Dir
32+-- | A map for tracking the file existence
33+type FileExistsMap = (Map NormalizedFilePath Bool)
35+-- | A wrapper around a mutable 'FileExistsMap'
36+newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
38+instance IsIdeGlobal FileExistsMapVar
40+-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency
41+getFileExistsMapUntracked :: Action FileExistsMap
42+getFileExistsMapUntracked = do
43+ FileExistsMapVar v <- getIdeGlobalAction
46+-- | Modify the global store of file exists
47+modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action ()
48+modifyFileExistsAction f = do
49+ FileExistsMapVar var <- getIdeGlobalAction
50+ liftIO $ modifyVar_ var f
52+-- | Modify the global store of file exists
53+modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
54+modifyFileExists state changes = do
55+ FileExistsMapVar var <- getIdeGlobalState state
56+ changesMap <- evaluate $ Map.fromList changes
58+ -- Masked to ensure that the previous values are flushed together with the map update
61+ modifyVar_ var $ evaluate . Map.union changesMap
62+ -- flush previous values
63+ mapM_ (deleteValue state GetFileExists . fst) changes
65+-------------------------------------------------------------------------------------
67+type instance RuleResult GetFileExists = Bool
69+data GetFileExists = GetFileExists
70+ deriving (Eq, Show, Typeable, Generic)
72+instance NFData GetFileExists
73+instance Hashable GetFileExists
74+instance Binary GetFileExists
76+-- | Returns True if the file exists
77+-- Note that a file is not considered to exist unless it is saved to disk.
78+-- In particular, VFS existence is not enough.
79+-- Consider the following example:
80+-- 1. The file @A.hs@ containing the line @import B@ is added to the files of interest
81+-- Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing
82+-- 2. The editor creates a new buffer @B.hs@
83+-- Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up
84+-- Most editors, e.g. VSCode, only send the event when the file is saved to disk.
85+getFileExists :: NormalizedFilePath -> Action Bool
86+getFileExists fp = use_ GetFileExists fp
88+-- | Installs the 'getFileExists' rules.
89+-- Provides a fast implementation if client supports dynamic watched files.
90+-- Creates a global state as a side effect in that case.
91+fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
92+fileExistsRules getLspId ClientCapabilities{_workspace}
93+ | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
94+ , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
95+ , Just True <- _dynamicRegistration
96+ = fileExistsRulesFast getLspId
97+ | otherwise = fileExistsRulesSlow
99+-- Requires an lsp client that provides WatchedFiles notifications.
100+fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
101+fileExistsRulesFast getLspId vfs = do
102+ addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
103+ defineEarlyCutoff $ \GetFileExists file -> do
104+ fileExistsMap <- getFileExistsMapUntracked
105+ let mbFilesWatched = Map.lookup file fileExistsMap
106+ case mbFilesWatched of
107+ Just fv -> pure (summarizeExists fv, ([], Just fv))
109+ exist <- liftIO $ getFileExistsVFS vfs file
110+ ShakeExtras { eventer } <- getShakeExtras
112+ -- add a listener for VFS Create/Delete file events,
113+ -- taking the FileExistsMap lock to prevent race conditions
114+ -- that would lead to multiple listeners for the same path
115+ modifyFileExistsAction $ \x -> do
116+ case Map.insertLookupWithKey (\_ x _ -> x) file exist x of
118+ -- if the listener addition fails, we never recover. This is a bug.
119+ addListener eventer file
122+ -- if the key was already there, do nothing
125+ pure (summarizeExists exist, ([], Just exist))
127+ addListener eventer fp = do
130+ req = RequestMessage "2.0" reqId ClientRegisterCapability regParams
131+ fpAsId = T.pack $ fromNormalizedFilePath fp
132+ regParams = RegistrationParams (List [registration])
133+ registration = Registration fpAsId
134+ WorkspaceDidChangeWatchedFiles
135+ (Just (A.toJSON regOptions))
137+ DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }
138+ watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp
139+ , kind = Just 5 -- Create and Delete events only
142+ eventer $ ReqRegisterCapability req
144+summarizeExists :: Bool -> Maybe BS.ByteString
145+summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
147+fileExistsRulesSlow:: VFSHandle -> Rules ()
148+fileExistsRulesSlow vfs = do
149+ defineEarlyCutoff $ \GetFileExists file -> do
151+ exist <- liftIO $ getFileExistsVFS vfs file
152+ pure (summarizeExists exist, ([], Just exist))
154+getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool
155+getFileExistsVFS vfs file = do
156+ -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
157+ -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
158+ -- cached 'No' rather than an exception in the wrong place
159+ handle (\(_ :: IOException) -> return False) $
160+ (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
161+ Dir.doesFileExist (fromNormalizedFilePath file)
163+--------------------------------------------------------------------------------------------------
164+-- The message definitions below probably belong in haskell-lsp-types
166+data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions
167+ { watchers :: List FileSystemWatcher
170+instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where
171+ toJSON DidChangeWatchedFilesRegistrationOptions {..} =
172+ A.object ["watchers" A..= watchers]
174+data FileSystemWatcher = FileSystemWatcher
175+ { -- | The glob pattern to watch.
176+ -- For details on glob pattern syntax, check the spec: https://microsoft.github.io/language-server-protocol/specifications/specification-3-14/#workspace_didChangeWatchedFiles
177+ globPattern :: String
178+ -- | The kind of event to subscribe to. Defaults to all.
179+ -- Defined as a bitmap of Create(1), Change(2), and Delete(4)
183+instance A.ToJSON FileSystemWatcher where
184+ toJSON FileSystemWatcher {..} =
186+ $ ["globPattern" A..= globPattern]
187+ ++ [ "kind" A..= x | Just x <- [kind] ]