@@ -0,0 +1,187 @@
1+{-# LANGUAGE OverloadedLists #-}
2+{-# LANGUAGE TypeFamilies #-}
3+{-# LANGUAGE UndecidableInstances #-}
4+module Development.IDE.Core.FileExists
5+ ( fileExistsRules
6+ , modifyFileExists
7+ , getFileExists
8+ )
9+where
10+
11+import Control.Concurrent.Extra
12+import Control.Exception
13+import Control.Monad.Extra
14+import qualified Data.Aeson as A
15+import Data.Binary
16+import qualified Data.ByteString as BS
17+import Data.Map.Strict ( Map )
18+import qualified Data.Map.Strict as Map
19+import Data.Maybe
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
26+import GHC.Generics
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
31+
32+-- | A map for tracking the file existence
33+type FileExistsMap = (Map NormalizedFilePath Bool)
34+
35+-- | A wrapper around a mutable 'FileExistsMap'
36+newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
37+
38+instance IsIdeGlobal FileExistsMapVar
39+
40+-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency
41+getFileExistsMapUntracked :: Action FileExistsMap
42+getFileExistsMapUntracked = do
43+ FileExistsMapVar v <- getIdeGlobalAction
44+ liftIO $ readVar v
45+
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
51+
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
57+
58+ -- Masked to ensure that the previous values are flushed together with the map update
59+ mask $ \_ -> do
60+ -- update the map
61+ modifyVar_ var $ evaluate . Map.union changesMap
62+ -- flush previous values
63+ mapM_ (deleteValue state GetFileExists . fst) changes
64+
65+-------------------------------------------------------------------------------------
66+
67+type instance RuleResult GetFileExists = Bool
68+
69+data GetFileExists = GetFileExists
70+ deriving (Eq, Show, Typeable, Generic)
71+
72+instance NFData GetFileExists
73+instance Hashable GetFileExists
74+instance Binary GetFileExists
75+
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
87+
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
98+
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))
108+ Nothing -> do
109+ exist <- liftIO $ getFileExistsVFS vfs file
110+ ShakeExtras { eventer } <- getShakeExtras
111+
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
117+ (Nothing, x') -> do
118+ -- if the listener addition fails, we never recover. This is a bug.
119+ addListener eventer file
120+ return x'
121+ (Just _, _) ->
122+ -- if the key was already there, do nothing
123+ return x
124+
125+ pure (summarizeExists exist, ([], Just exist))
126+ where
127+ addListener eventer fp = do
128+ reqId <- getLspId
129+ let
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))
136+ regOptions =
137+ DidChangeWatchedFilesRegistrationOptions { watchers = List [watcher] }
138+ watcher = FileSystemWatcher { globPattern = fromNormalizedFilePath fp
139+ , kind = Just 5 -- Create and Delete events only
140+ }
141+
142+ eventer $ ReqRegisterCapability req
143+
144+summarizeExists :: Bool -> Maybe BS.ByteString
145+summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
146+
147+fileExistsRulesSlow:: VFSHandle -> Rules ()
148+fileExistsRulesSlow vfs = do
149+ defineEarlyCutoff $ \GetFileExists file -> do
150+ alwaysRerun
151+ exist <- liftIO $ getFileExistsVFS vfs file
152+ pure (summarizeExists exist, ([], Just exist))
153+
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)
162+
163+--------------------------------------------------------------------------------------------------
164+-- The message definitions below probably belong in haskell-lsp-types
165+
166+data DidChangeWatchedFilesRegistrationOptions = DidChangeWatchedFilesRegistrationOptions
167+ { watchers :: List FileSystemWatcher
168+ }
169+
170+instance A.ToJSON DidChangeWatchedFilesRegistrationOptions where
171+ toJSON DidChangeWatchedFilesRegistrationOptions {..} =
172+ A.object ["watchers" A..= watchers]
173+
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)
180+ , kind :: Maybe Int
181+ }
182+
183+instance A.ToJSON FileSystemWatcher where
184+ toJSON FileSystemWatcher {..} =
185+ A.object
186+ $ ["globPattern" A..= globPattern]
187+ ++ [ "kind" A..= x | Just x <- [kind] ]