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