git.iko.soy/ghcide
on debug-modtime help sign in
ghcide/src/Development/IDE/Core/FileStore.hs
191 lines 7.7 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 ) where
17import System.IO
18import Development.IDE.GHC.Orphans()
19import Development.IDE.Core.Shake
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 Development.Shake
26import Development.Shake.Classes
27import Control.Exception
28import GHC.Generics
29import Data.Either.Extra
30import System.IO.Error
31import qualified Data.ByteString.Char8 as BS
32import Development.IDE.Types.Diagnostics
33import Development.IDE.Types.Location
34import qualified Data.Rope.UTF16 as Rope
36#ifdef mingw32_HOST_OS
37import Data.Time
38import qualified System.Directory as Dir
39#else
40import Foreign.Ptr
41import Foreign.C.String
42import Foreign.C.Types
43import Foreign.Marshal (alloca)
44import Foreign.Storable
45import qualified System.Posix.Error as Posix
46#endif
48import Language.Haskell.LSP.Core
49import Language.Haskell.LSP.VFS
51-- | haskell-lsp manages the VFS internally and automatically so we cannot use
52-- the builtin VFS without spawning up an LSP server. To be able to test things
53-- like `setBufferModified` we abstract over the VFS implementation.
54data VFSHandle = VFSHandle
55 { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
56 -- ^ get the contents of a virtual file
57 , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
58 -- ^ set a specific file to a value. If Nothing then we are ignoring these
59 -- signals anyway so can just say something was modified
60 }
62instance IsIdeGlobal VFSHandle
64makeVFSHandle :: IO VFSHandle
65makeVFSHandle = do
66 vfsVar <- newVar (1, Map.empty)
67 pure VFSHandle
68 { getVirtualFile = \uri -> do
69 (_nextVersion, vfs) <- readVar vfsVar
70 pure $ Map.lookup uri vfs
71 , setVirtualFileContents = Just $ \uri content ->
72 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
73 case content of
74 Nothing -> Map.delete uri vfs
75 -- The second version number is only used in persistFileVFS which we do not use so we set it to 0.
76 Just content -> Map.insert uri (VirtualFile nextVersion 0 (Rope.fromText content)) 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 T.Text)
89data GetFileContents = GetFileContents
90 deriving (Eq, Show, Generic)
91instance Hashable GetFileContents
92instance NFData GetFileContents
93instance Binary GetFileContents
95getModificationTimeRule :: VFSHandle -> Rules ()
96getModificationTimeRule vfs =
97 defineEarlyCutoff $ \GetModificationTime file -> do
98 let file' = fromNormalizedFilePath file
99 let wrap time@(l,s) = do
100 hPutStrLn stderr (show $ BS.pack $ show time)
101 pure (Just $ BS.pack $ show time, ([], Just $ ModificationTime l s))
102 alwaysRerun
103 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
104 case mbVirtual of
105 Just (virtualFileVersion -> ver) ->
106 pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
107 Nothing -> liftIO $ (wrap =<< getModTime file')
108 `catch` \(e :: IOException) -> do
109 let err | isDoesNotExistError e = "File does not exist: " ++ file'
110 | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
111 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
112 where
113 -- Dir.getModificationTime is surprisingly slow since it performs
114 -- a ton of conversions. Since we do not actually care about
115 -- the format of the time, we can get away with something cheaper.
116 -- For now, we only try to do this on Unix systems where it seems to get the
117 -- time spent checking file modifications (which happens on every change)
118 -- from > 0.5s to ~0.15s.
119 -- We might also want to try speeding this up on Windows at some point.
120 -- TODO leverage DidChangeWatchedFile lsp notifications on clients that
121 -- support them, as done for GetFileExists
122 getModTime :: FilePath -> IO (Int,Int)
123 getModTime f =
124#ifdef mingw32_HOST_OS
125 do time <- Dir.getModificationTime f
126 let !day = fromInteger $ toModifiedJulianDay $ utctDay time
127 !dayTime = fromInteger $ diffTimeToPicoseconds $ utctDayTime time
128 pure (day, dayTime)
129#else
130 withCString f $ \f' ->
131 alloca $ \secPtr ->
132 alloca $ \nsecPtr -> do
133 Posix.throwErrnoPathIfMinus1Retry_ "getmodtime" f $ c_getModTime f' secPtr nsecPtr
134 sec <- peek secPtr
135 nsec <- peek nsecPtr
136 hPutStrLn stderr (show (f, sec, nsec))
137 pure (fromEnum sec, fromIntegral nsec)
139-- Sadly even unix’s getFileStatus + modificationTimeHiRes is still about twice as slow
140-- as doing the FFI call ourselves :(.
141foreign import ccall "getmodtime" c_getModTime :: CString -> Ptr CTime -> Ptr CLong -> IO Int
142#endif
144getFileContentsRule :: VFSHandle -> Rules ()
145getFileContentsRule vfs =
146 define $ \GetFileContents file -> do
147 -- need to depend on modification time to introduce a dependency with Cutoff
148 time <- use_ GetModificationTime file
149 res <- liftIO $ ideTryIOException file $ do
150 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
151 pure $ Rope.toText . _text <$> mbVirtual
152 case res of
153 Left err -> return ([err], Nothing)
154 Right contents -> return ([], Just (time, contents))
156ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
157ideTryIOException fp act =
158 mapLeft
159 (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
160 <$> try act
163getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe T.Text)
164getFileContents = use_ GetFileContents
166fileStoreRules :: VFSHandle -> Rules ()
167fileStoreRules vfs = do
168 addIdeGlobal vfs
169 getModificationTimeRule vfs
170 getFileContentsRule vfs
173-- | Notify the compiler service that a particular file has been modified.
174-- Use 'Nothing' to say the file is no longer in the virtual file system
175-- but should be sourced from disk, or 'Just' to give its new value.
176setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
177setBufferModified state absFile contents = do
178 VFSHandle{..} <- getIdeGlobalState state
179 whenJust setVirtualFileContents $ \set ->
180 set (filePathToUri' absFile) contents
181 void $ shakeRun state []
183-- | Note that some buffer somewhere has been modified, but don't say what.
184-- Only valid if the virtual file system was initialised by LSP, as that
185-- independently tracks which files are modified.
186setSomethingModified :: IdeState -> IO ()
187setSomethingModified state = do
188 VFSHandle{..} <- getIdeGlobalState state
189 when (isJust setVirtualFileContents) $
190 fail "setSomethingModified can't be called on this type of VFSHandle"
191 void $ shakeRun state []