git.iko.soy/ghcide
on debugging help sign in
ghcide/src/Development/IDE/Core/FileStore.hs
236 lines 9.3 kB history raw
1-- Copyright (c) 2019 The DAML Authors. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
3{-# LANGUAGE CPP #-}
4{-# LANGUAGE TypeFamilies #-}
6module Development.IDE.Core.FileStore(
7 getFileExists, getFileContents,
8 setBufferModified,
9 setSomethingModified,
10 fileStoreRules,
11 VFSHandle,
12 makeVFSHandle,
13 makeLSPVFSHandle,
14 getSourceFingerprint
15 ) where
17import Foreign.Ptr
18import Foreign.ForeignPtr
19import Fingerprint
20import StringBuffer
21import Development.IDE.GHC.Orphans()
22import Development.IDE.GHC.Util
24import Control.Concurrent.Extra
25import qualified Data.Map.Strict as Map
26import Data.Maybe
27import qualified Data.Text as T
28import Control.Monad.Extra
29import qualified System.Directory as Dir
30import Development.Shake
31import Development.Shake.Classes
32import Development.IDE.Core.Shake
33import Control.Exception
34import GHC.Generics
35import Data.Either.Extra
36import System.IO.Error
37import qualified Data.ByteString.Char8 as BS
38import Development.IDE.Types.Diagnostics
39import Development.IDE.Types.Location
40import qualified Data.Rope.UTF16 as Rope
42#ifdef mingw32_HOST_OS
43import Data.Time
44#else
45import Foreign.C.String
46import Foreign.C.Types
47import Foreign.Marshal (alloca)
48import Foreign.Storable
49import qualified System.Posix.Error as Posix
50#endif
52import Language.Haskell.LSP.Core
53import Language.Haskell.LSP.VFS
55-- | haskell-lsp manages the VFS internally and automatically so we cannot use
56-- the builtin VFS without spawning up an LSP server. To be able to test things
57-- like `setBufferModified` we abstract over the VFS implementation.
58data VFSHandle = VFSHandle
59 { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
60 -- ^ get the contents of a virtual file
61 , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
62 -- ^ set a specific file to a value. If Nothing then we are ignoring these
63 -- signals anyway so can just say something was modified
64 }
66instance IsIdeGlobal VFSHandle
68makeVFSHandle :: IO VFSHandle
69makeVFSHandle = do
70 vfsVar <- newVar (1, Map.empty)
71 pure VFSHandle
72 { getVirtualFile = \uri -> do
73 (_nextVersion, vfs) <- readVar vfsVar
74 pure $ Map.lookup uri vfs
75 , setVirtualFileContents = Just $ \uri content ->
76 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
77 case content of
78 Nothing -> Map.delete uri vfs
79 -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.
80 Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) vfs
81 }
83makeLSPVFSHandle :: LspFuncs c -> VFSHandle
84makeLSPVFSHandle lspFuncs = VFSHandle
85 { getVirtualFile = getVirtualFileFunc lspFuncs
86 , setVirtualFileContents = Nothing
87 }
90-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
91type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
93-- | Does the file exist.
94type instance RuleResult GetFileExists = Bool
96type instance RuleResult FingerprintSource = Fingerprint
98data GetFileExists = GetFileExists
99 deriving (Eq, Show, Generic)
100instance Hashable GetFileExists
101instance NFData GetFileExists
102instance Binary GetFileExists
104data GetFileContents = GetFileContents
105 deriving (Eq, Show, Generic)
106instance Hashable GetFileContents
107instance NFData GetFileContents
108instance Binary GetFileContents
110data FingerprintSource = FingerprintSource
111 deriving (Eq, Show, Generic)
112instance Hashable FingerprintSource
113instance NFData FingerprintSource
114instance Binary FingerprintSource
116fingerprintSourceRule :: Rules ()
117fingerprintSourceRule =
118 define $ \FingerprintSource file -> do
119 (_, mbContent) <- getFileContents file
120 content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent
121 fingerprint <- liftIO $ fpStringBuffer content
122 pure ([], Just fingerprint)
123 where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
125getFileExistsRule :: VFSHandle -> Rules ()
126getFileExistsRule vfs =
127 defineEarlyCutoff $ \GetFileExists file -> do
128 alwaysRerun
129 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
130 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
131 Dir.doesFileExist (fromNormalizedFilePath file)
132 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
135getModificationTimeRule :: VFSHandle -> Rules ()
136getModificationTimeRule vfs =
137 defineEarlyCutoff $ \GetModificationTime file -> do
138 let file' = fromNormalizedFilePath file
139 let wrap time = (Just time, ([], Just $ ModificationTime time))
140 alwaysRerun
141 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
142 case mbVirtual of
143 Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
144 Nothing -> liftIO $ fmap wrap (getModTime file')
145 `catch` \(e :: IOException) -> do
146 let err | isDoesNotExistError e = "File does not exist: " ++ file'
147 | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
148 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
149 where
150 -- Dir.getModificationTime is surprisingly slow since it performs
151 -- a ton of conversions. Since we do not actually care about
152 -- the format of the time, we can get away with something cheaper.
153 -- For now, we only try to do this on Unix systems where it seems to get the
154 -- time spent checking file modifications (which happens on every change)
155 -- from > 0.5s to ~0.15s.
156 -- We might also want to try speeding this up on Windows at some point.
157 getModTime :: FilePath -> IO BS.ByteString
158 getModTime f =
159#ifdef mingw32_HOST_OS
160 do time <- Dir.getModificationTime f
161 pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)
162#else
163 withCString f $ \f' ->
164 alloca $ \secPtr ->
165 alloca $ \nsecPtr -> do
166 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
167 sec <- peek secPtr
168 nsec <- peek nsecPtr
169 pure $! BS.pack $ show sec <> "." <> show nsec
171-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
172-- as doing the FFI call ourselves :(.
173foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
174#endif
176getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint
177getSourceFingerprint = use_ FingerprintSource
179getFileContentsRule :: VFSHandle -> Rules ()
180getFileContentsRule vfs =
181 define $ \GetFileContents file -> do
182 -- need to depend on modification time to introduce a dependency with Cutoff
183 time <- use_ GetModificationTime file
184 res <- liftIO $ ideTryIOException file $ do
185 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
186 pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual
187 case res of
188 Left err -> return ([err], Nothing)
189 Right contents -> return ([], Just (time, contents))
191ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
192ideTryIOException fp act =
193 mapLeft
194 (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
195 <$> try act
198getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)
199getFileContents = use_ GetFileContents
201getFileExists :: NormalizedFilePath -> Action Bool
202getFileExists =
203 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
204 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
205 -- cached 'No' rather than an exception in the wrong place
206 use_ GetFileExists
209fileStoreRules :: VFSHandle -> Rules ()
210fileStoreRules vfs = do
211 addIdeGlobal vfs
212 getModificationTimeRule vfs
213 getFileContentsRule vfs
214 getFileExistsRule vfs
215 fingerprintSourceRule
218-- | Notify the compiler service that a particular file has been modified.
219-- Use 'Nothing' to say the file is no longer in the virtual file system
220-- but should be sourced from disk, or 'Just' to give its new value.
221setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
222setBufferModified state absFile contents = do
223 VFSHandle{..} <- getIdeGlobalState state
224 whenJust setVirtualFileContents $ \set ->
225 set (filePathToUri' absFile) contents
226 void $ shakeRun state []
228-- | Note that some buffer somewhere has been modified, but don't say what.
229-- Only valid if the virtual file system was initialised by LSP, as that
230-- independently tracks which files are modified.
231setSomethingModified :: IdeState -> IO ()
232setSomethingModified state = do
233 VFSHandle{..} <- getIdeGlobalState state
234 when (isJust setVirtualFileContents) $
235 fail "setSomethingModified can't be called on this type of VFSHandle"
236 void $ shakeRun state []