git.iko.soy/ghcide
on debug-modtime help sign in
ghcide/src/Development/IDE/Core/FileExists.hs
177 lines 7.6 kB history raw
1{-# LANGUAGE OverloadedLists #-}
2{-# LANGUAGE TypeFamilies #-}
3{-# LANGUAGE UndecidableInstances #-}
4module Development.IDE.Core.FileExists
5 ( fileExistsRules
6 , modifyFileExists
7 , getFileExists
8 )
9where
11import Control.Concurrent.Extra
12import Control.Exception
13import Control.Monad.Extra
14import qualified Data.Aeson as A
15import Data.Binary
16import qualified Data.ByteString as BS
17import Data.HashMap.Strict (HashMap)
18import qualified Data.HashMap.Strict as HashMap
19import Data.Maybe
20import qualified Data.Text as T
21import Development.IDE.Core.FileStore
22import Development.IDE.Core.IdeConfiguration
23import Development.IDE.Core.Shake
24import Development.IDE.Types.Location
25import Development.IDE.Types.Logger
26import Development.Shake
27import Development.Shake.Classes
28import GHC.Generics
29import Language.Haskell.LSP.Messages
30import Language.Haskell.LSP.Types
31import Language.Haskell.LSP.Types.Capabilities
32import qualified System.Directory as Dir
34-- | A map for tracking the file existence
35type FileExistsMap = (HashMap NormalizedFilePath Bool)
37-- | A wrapper around a mutable 'FileExistsMap'
38newtype FileExistsMapVar = FileExistsMapVar (Var FileExistsMap)
40instance IsIdeGlobal FileExistsMapVar
42-- | Grab the current global value of 'FileExistsMap' without acquiring a dependency
43getFileExistsMapUntracked :: Action FileExistsMap
44getFileExistsMapUntracked = do
45 FileExistsMapVar v <- getIdeGlobalAction
46 liftIO $ readVar v
48-- | Modify the global store of file exists
49modifyFileExistsAction :: (FileExistsMap -> IO FileExistsMap) -> Action ()
50modifyFileExistsAction f = do
51 FileExistsMapVar var <- getIdeGlobalAction
52 liftIO $ modifyVar_ var f
54-- | Modify the global store of file exists
55modifyFileExists :: IdeState -> [(NormalizedFilePath, Bool)] -> IO ()
56modifyFileExists state changes = do
57 FileExistsMapVar var <- getIdeGlobalState state
58 changesMap <- evaluate $ HashMap.fromList changes
60 -- Masked to ensure that the previous values are flushed together with the map update
61 mask $ \_ -> do
62 -- update the map
63 modifyVar_ var $ evaluate . HashMap.union changesMap
64 -- flush previous values
65 mapM_ (deleteValue state GetFileExists . fst) changes
67-------------------------------------------------------------------------------------
69type instance RuleResult GetFileExists = Bool
71data GetFileExists = GetFileExists
72 deriving (Eq, Show, Typeable, Generic)
74instance NFData GetFileExists
75instance Hashable GetFileExists
76instance Binary GetFileExists
78-- | Returns True if the file exists
79-- Note that a file is not considered to exist unless it is saved to disk.
80-- In particular, VFS existence is not enough.
81-- Consider the following example:
82-- 1. The file @A.hs@ containing the line @import B@ is added to the files of interest
83-- Since @B.hs@ is neither open nor exists, GetLocatedImports finds Nothing
84-- 2. The editor creates a new buffer @B.hs@
85-- Unless the editor also sends a @DidChangeWatchedFile@ event, ghcide will not pick it up
86-- Most editors, e.g. VSCode, only send the event when the file is saved to disk.
87getFileExists :: NormalizedFilePath -> Action Bool
88getFileExists fp = use_ GetFileExists fp
90-- | Installs the 'getFileExists' rules.
91-- Provides a fast implementation if client supports dynamic watched files.
92-- Creates a global state as a side effect in that case.
93fileExistsRules :: IO LspId -> ClientCapabilities -> VFSHandle -> Rules ()
94fileExistsRules getLspId ClientCapabilities{_workspace} vfs
95 | Just WorkspaceClientCapabilities{_didChangeWatchedFiles} <- _workspace
96 , Just DidChangeWatchedFilesClientCapabilities{_dynamicRegistration} <- _didChangeWatchedFiles
97 , Just True <- _dynamicRegistration
98 = fileExistsRulesFast getLspId vfs
99 | otherwise = do
100 logger <- logger <$> getShakeExtrasRules
101 liftIO $ logDebug logger "Warning: Client does not support watched files. Falling back to OS polling"
102 fileExistsRulesSlow vfs
104-- Requires an lsp client that provides WatchedFiles notifications.
105fileExistsRulesFast :: IO LspId -> VFSHandle -> Rules ()
106fileExistsRulesFast getLspId vfs = do
107 addIdeGlobal . FileExistsMapVar =<< liftIO (newVar [])
108 defineEarlyCutoff $ \GetFileExists file -> do
109 isWf <- isWorkspaceFile file
110 if isWf
111 then fileExistsFast getLspId vfs file
112 else fileExistsSlow vfs file
114fileExistsFast :: IO LspId -> VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
115fileExistsFast getLspId vfs file = do
116 fileExistsMap <- getFileExistsMapUntracked
117 let mbFilesWatched = HashMap.lookup file fileExistsMap
118 case mbFilesWatched of
119 Just fv -> pure (summarizeExists fv, ([], Just fv))
120 Nothing -> do
121 exist <- liftIO $ getFileExistsVFS vfs file
122 ShakeExtras { eventer } <- getShakeExtras
124 -- add a listener for VFS Create/Delete file events,
125 -- taking the FileExistsMap lock to prevent race conditions
126 -- that would lead to multiple listeners for the same path
127 modifyFileExistsAction $ \x -> do
128 case HashMap.alterF (,Just exist) file x of
129 (Nothing, x') -> do
130 -- if the listener addition fails, we never recover. This is a bug.
131 addListener eventer file
132 return x'
133 (Just _, _) ->
134 -- if the key was already there, do nothing
135 return x
137 pure (summarizeExists exist, ([], Just exist))
138 where
139 addListener eventer fp = do
140 reqId <- getLspId
141 let
142 req = RequestMessage "2.0" reqId ClientRegisterCapability regParams
143 fpAsId = T.pack $ fromNormalizedFilePath fp
144 regParams = RegistrationParams (List [registration])
145 registration = Registration fpAsId
146 WorkspaceDidChangeWatchedFiles
147 (Just (A.toJSON regOptions))
148 regOptions =
149 DidChangeWatchedFilesRegistrationOptions { _watchers = List [watcher] }
150 watchKind = WatchKind { _watchCreate = True, _watchChange = False, _watchDelete = True}
151 watcher = FileSystemWatcher { _globPattern = fromNormalizedFilePath fp
152 , _kind = Just watchKind
153 }
155 eventer $ ReqRegisterCapability req
157summarizeExists :: Bool -> Maybe BS.ByteString
158summarizeExists x = Just $ if x then BS.singleton 1 else BS.empty
160fileExistsRulesSlow:: VFSHandle -> Rules ()
161fileExistsRulesSlow vfs =
162 defineEarlyCutoff $ \GetFileExists file -> fileExistsSlow vfs file
164fileExistsSlow :: VFSHandle -> NormalizedFilePath -> Action (Maybe BS.ByteString, ([a], Maybe Bool))
165fileExistsSlow vfs file = do
166 alwaysRerun
167 exist <- liftIO $ getFileExistsVFS vfs file
168 pure (summarizeExists exist, ([], Just exist))
170getFileExistsVFS :: VFSHandle -> NormalizedFilePath -> IO Bool
171getFileExistsVFS vfs file = do
172 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
173 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
174 -- cached 'No' rather than an exception in the wrong place
175 handle (\(_ :: IOException) -> return False) $
176 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
177 Dir.doesFileExist (fromNormalizedFilePath file)