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