git.iko.soy/ghcide
on multi-component help sign in
ghcide/src/Development/IDE/Core/FileStore.hs
210 lines 8.4 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 getFileContents,
8 getVirtualFile,
9 setBufferModified,
10 setSomethingModified,
11 fileStoreRules,
12 VFSHandle,
13 makeVFSHandle,
14 makeLSPVFSHandle,
15 getSourceFingerprint
16 ) where
18import Foreign.Ptr
19import Foreign.ForeignPtr
20import Fingerprint
21import StringBuffer
22import Development.IDE.GHC.Orphans()
23import Development.IDE.GHC.Util
24import Development.IDE.Core.Shake
25import Control.Concurrent.Extra
26import qualified Data.Map.Strict as Map
27import Data.Maybe
28import qualified Data.Text as T
29import Control.Monad.Extra
30import Development.Shake
31import Development.Shake.Classes
32import Control.Exception
33import GHC.Generics
34import Data.Either.Extra
35import System.IO.Error
36import qualified Data.ByteString.Char8 as BS
37import Development.IDE.Types.Diagnostics
38import Development.IDE.Types.Location
39import qualified Data.Rope.UTF16 as Rope
41#ifdef mingw32_HOST_OS
42import Data.Time
43import qualified System.Directory as Dir
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)
93type instance RuleResult FingerprintSource = Fingerprint
95data GetFileContents = GetFileContents
96 deriving (Eq, Show, Generic)
97instance Hashable GetFileContents
98instance NFData GetFileContents
99instance Binary GetFileContents
101data FingerprintSource = FingerprintSource
102 deriving (Eq, Show, Generic)
103instance Hashable FingerprintSource
104instance NFData FingerprintSource
105instance Binary FingerprintSource
107fingerprintSourceRule :: Rules ()
108fingerprintSourceRule =
109 define $ \FingerprintSource file -> do
110 (_, mbContent) <- getFileContents file
111 content <- liftIO $ maybe (hGetStringBuffer $ fromNormalizedFilePath file) pure mbContent
112 fingerprint <- liftIO $ fpStringBuffer content
113 pure ([], Just fingerprint)
114 where fpStringBuffer (StringBuffer buf len cur) = withForeignPtr buf $ \ptr -> fingerprintData (ptr `plusPtr` cur) len
116getModificationTimeRule :: VFSHandle -> Rules ()
117getModificationTimeRule vfs =
118 defineEarlyCutoff $ \GetModificationTime file -> do
119 let file' = fromNormalizedFilePath file
120 let wrap time = (Just time, ([], Just $ ModificationTime time))
121 alwaysRerun
122 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
123 case mbVirtual of
124 Just (virtualFileVersion -> ver) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
125 Nothing -> liftIO $ fmap wrap (getModTime file')
126 `catch` \(e :: IOException) -> do
127 let err | isDoesNotExistError e = "File does not exist: " ++ file'
128 | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
129 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
130 where
131 -- Dir.getModificationTime is surprisingly slow since it performs
132 -- a ton of conversions. Since we do not actually care about
133 -- the format of the time, we can get away with something cheaper.
134 -- For now, we only try to do this on Unix systems where it seems to get the
135 -- time spent checking file modifications (which happens on every change)
136 -- from > 0.5s to ~0.15s.
137 -- We might also want to try speeding this up on Windows at some point.
138 -- TODO leverage DidChangeWatchedFile lsp notifications on clients that
139 -- support them, as done for GetFileExists
140 getModTime :: FilePath -> IO BS.ByteString
141 getModTime f =
142#ifdef mingw32_HOST_OS
143 do time <- Dir.getModificationTime f
144 pure $! BS.pack $ show (toModifiedJulianDay $ utctDay time, diffTimeToPicoseconds $ utctDayTime time)
145#else
146 withCString f $ \f' ->
147 alloca $ \secPtr ->
148 alloca $ \nsecPtr -> do
149 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
150 sec <- peek secPtr
151 nsec <- peek nsecPtr
152 pure $! BS.pack $ show sec <> "." <> show nsec
154-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
155-- as doing the FFI call ourselves :(.
156foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
157#endif
159getSourceFingerprint :: NormalizedFilePath -> Action Fingerprint
160getSourceFingerprint = use_ FingerprintSource
162getFileContentsRule :: VFSHandle -> Rules ()
163getFileContentsRule vfs =
164 define $ \GetFileContents file -> do
165 -- need to depend on modification time to introduce a dependency with Cutoff
166 time <- use_ GetModificationTime file
167 res <- liftIO $ ideTryIOException file $ do
168 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
169 pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual
170 case res of
171 Left err -> return ([err], Nothing)
172 Right contents -> return ([], Just (time, contents))
174ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
175ideTryIOException fp act =
176 mapLeft
177 (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
178 <$> try act
181getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)
182getFileContents = use_ GetFileContents
184fileStoreRules :: VFSHandle -> Rules ()
185fileStoreRules vfs = do
186 addIdeGlobal vfs
187 getModificationTimeRule vfs
188 getFileContentsRule vfs
189 fingerprintSourceRule
192-- | Notify the compiler service that a particular file has been modified.
193-- Use 'Nothing' to say the file is no longer in the virtual file system
194-- but should be sourced from disk, or 'Just' to give its new value.
195setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
196setBufferModified state absFile contents = do
197 VFSHandle{..} <- getIdeGlobalState state
198 whenJust setVirtualFileContents $ \set ->
199 set (filePathToUri' absFile) contents
200 void $ shakeRun state []
202-- | Note that some buffer somewhere has been modified, but don't say what.
203-- Only valid if the virtual file system was initialised by LSP, as that
204-- independently tracks which files are modified.
205setSomethingModified :: IdeState -> IO ()
206setSomethingModified state = do
207 VFSHandle{..} <- getIdeGlobalState state
208 when (isJust setVirtualFileContents) $
209 fail "setSomethingModified can't be called on this type of VFSHandle"
210 void $ shakeRun state []