git.iko.soy/ghcide
on eddf78a help sign in
ghcide/src/Development/IDE/Core/FileStore.hs
180 lines 7.0 kB history raw
1-- Copyright (c) 2019 Digital Asset (Switzerland) GmbH and/or its affiliates. All rights reserved.
2-- SPDX-License-Identifier: Apache-2.0
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 Data.Time.Clock
25import Control.Monad.Extra
26import qualified System.Directory as Dir
27import Development.Shake
28import Development.Shake.Classes
29import Development.IDE.Core.Shake
30import Control.Exception
31import GHC.Generics
32import Data.Either.Extra
33import System.IO.Error
34import qualified Data.ByteString.Char8 as BS
35import Development.IDE.Types.Diagnostics
36import Development.IDE.Types.Location
37import qualified Data.Rope.UTF16 as Rope
38import Data.Time
40import Language.Haskell.LSP.Core
41import Language.Haskell.LSP.VFS
43-- | haskell-lsp manages the VFS internally and automatically so we cannot use
44-- the builtin VFS without spawning up an LSP server. To be able to test things
45-- like `setBufferModified` we abstract over the VFS implementation.
46data VFSHandle = VFSHandle
47 { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
48 -- ^ get the contents of a virtual file
49 , setVirtualFileContents :: Maybe (NormalizedUri -> Maybe T.Text -> IO ())
50 -- ^ set a specific file to a value. If Nothing then we are ignoring these
51 -- signals anyway so can just say something was modified
52 }
54instance IsIdeGlobal VFSHandle
56makeVFSHandle :: IO VFSHandle
57makeVFSHandle = do
58 vfsVar <- newVar (1, Map.empty)
59 pure VFSHandle
60 { getVirtualFile = \uri -> do
61 (_nextVersion, vfs) <- readVar vfsVar
62 pure $ Map.lookup uri vfs
63 , setVirtualFileContents = Just $ \uri content ->
64 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
65 case content of
66 Nothing -> Map.delete uri vfs
67 Just content -> Map.insert uri (VirtualFile nextVersion (Rope.fromText content) Nothing) vfs
68 }
70makeLSPVFSHandle :: LspFuncs c -> VFSHandle
71makeLSPVFSHandle lspFuncs = VFSHandle
72 { getVirtualFile = getVirtualFileFunc lspFuncs
73 , setVirtualFileContents = Nothing
74 }
77-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.
78type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)
80-- | Does the file exist.
81type instance RuleResult GetFileExists = Bool
84data GetFileExists = GetFileExists
85 deriving (Eq, Show, Generic)
86instance Hashable GetFileExists
87instance NFData GetFileExists
89data GetFileContents = GetFileContents
90 deriving (Eq, Show, Generic)
91instance Hashable GetFileContents
92instance NFData GetFileContents
95getFileExistsRule :: VFSHandle -> Rules ()
96getFileExistsRule vfs =
97 defineEarlyCutoff $ \GetFileExists file -> do
98 alwaysRerun
99 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
100 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
101 Dir.doesFileExist (fromNormalizedFilePath file)
102 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
105showTimePrecise :: UTCTime -> String
106showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
108getModificationTimeRule :: VFSHandle -> Rules ()
109getModificationTimeRule vfs =
110 defineEarlyCutoff $ \GetModificationTime file -> do
111 let file' = fromNormalizedFilePath file
112 let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just $ ModificationTime time))
113 alwaysRerun
114 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
115 case mbVirtual of
116 Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
117 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file')
118 `catch` \(e :: IOException) -> do
119 let err | isDoesNotExistError e = "File does not exist: " ++ file'
120 | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
121 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
124getFileContentsRule :: VFSHandle -> Rules ()
125getFileContentsRule vfs =
126 define $ \GetFileContents file -> do
127 -- need to depend on modification time to introduce a dependency with Cutoff
128 time <- use_ GetModificationTime file
129 res <- liftIO $ ideTryIOException file $ do
130 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
131 pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual
132 case res of
133 Left err -> return ([err], Nothing)
134 Right contents -> return ([], Just (time, contents))
136ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
137ideTryIOException fp act =
138 mapLeft
139 (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
140 <$> try act
143getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)
144getFileContents = use_ GetFileContents
146getFileExists :: NormalizedFilePath -> Action Bool
147getFileExists =
148 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
149 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
150 -- cached 'No' rather than an exception in the wrong place
151 use_ GetFileExists
154fileStoreRules :: VFSHandle -> Rules ()
155fileStoreRules vfs = do
156 addIdeGlobal vfs
157 getModificationTimeRule vfs
158 getFileContentsRule vfs
159 getFileExistsRule vfs
162-- | Notify the compiler service that a particular file has been modified.
163-- Use 'Nothing' to say the file is no longer in the virtual file system
164-- but should be sourced from disk, or 'Just' to give its new value.
165setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
166setBufferModified state absFile contents = do
167 VFSHandle{..} <- getIdeGlobalState state
168 whenJust setVirtualFileContents $ \set ->
169 set (filePathToUri' absFile) contents
170 void $ shakeRun state []
172-- | Note that some buffer somewhere has been modified, but don't say what.
173-- Only valid if the virtual file system was initialised by LSP, as that
174-- independently tracks which files are modified.
175setSomethingModified :: IdeState -> IO ()
176setSomethingModified state = do
177 VFSHandle{..} <- getIdeGlobalState state
178 when (isJust setVirtualFileContents) $
179 fail "setSomethingModified can't be called on this type of VFSHandle"
180 void $ shakeRun state []