git.iko.soy/ghcide
on 0336e41 help sign in
ghcide/src/Development/IDE/Core/FileStore.hs
171 lines 6.4 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 fileStoreRules,
10 VFSHandle,
11 makeVFSHandle,
12 makeLSPVFSHandle,
13 ) where
15import StringBuffer
16import Development.IDE.GHC.Orphans()
18import Control.Concurrent.Extra
19import qualified Data.Map.Strict as Map
20import Data.Maybe
21import qualified Data.Text as T
22import Data.Time.Clock
23import Control.Monad.Extra
24import qualified System.Directory as Dir
25import Development.Shake
26import Development.Shake.Classes
27import Development.IDE.Core.Shake
28import Control.Exception
29import GHC.Generics
30import Data.Either.Extra
31import System.IO.Error
32import qualified Data.ByteString.Char8 as BS
33import qualified StringBuffer as SB
34import Development.IDE.Types.Diagnostics
35import Development.IDE.Types.Location
36import qualified Data.Rope.UTF16 as Rope
37import Data.Time
39import Language.Haskell.LSP.Core
40import Language.Haskell.LSP.VFS
42-- | haskell-lsp manages the VFS internally and automatically so we cannot use
43-- the builtin VFS without spawning up an LSP server. To be able to test things
44-- like `setBufferModified` we abstract over the VFS implementation.
45data VFSHandle = VFSHandle
46 { getVirtualFile :: NormalizedUri -> IO (Maybe VirtualFile)
47 , setVirtualFileContents :: NormalizedUri -> Maybe T.Text -> IO ()
48 }
50instance IsIdeGlobal VFSHandle
52makeVFSHandle :: IO VFSHandle
53makeVFSHandle = do
54 vfsVar <- newVar (1, Map.empty)
55 pure VFSHandle
56 { getVirtualFile = \uri -> do
57 (_nextVersion, vfs) <- readVar vfsVar
58 pure $ Map.lookup uri vfs
59 , setVirtualFileContents = \uri content ->
60 modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure $ (nextVersion + 1, ) $
61 case content of
62 Nothing -> Map.delete uri vfs
63 Just content -> Map.insert uri (VirtualFile nextVersion (Rope.fromText content) Nothing) vfs
64 }
66makeLSPVFSHandle :: LspFuncs c -> VFSHandle
67makeLSPVFSHandle lspFuncs = VFSHandle
68 { getVirtualFile = getVirtualFileFunc lspFuncs
69 , setVirtualFileContents = \_ _ -> pure ()
70 -- ^ Handled internally by haskell-lsp.
71 }
74-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.
75type instance RuleResult GetFileContents = (FileVersion, StringBuffer)
77-- | Does the file exist.
78type instance RuleResult GetFileExists = Bool
81data GetFileExists = GetFileExists
82 deriving (Eq, Show, Generic)
83instance Hashable GetFileExists
84instance NFData GetFileExists
86data GetFileContents = GetFileContents
87 deriving (Eq, Show, Generic)
88instance Hashable GetFileContents
89instance NFData GetFileContents
92getFileExistsRule :: VFSHandle -> Rules ()
93getFileExistsRule vfs =
94 defineEarlyCutoff $ \GetFileExists file -> do
95 alwaysRerun
96 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
97 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
98 Dir.doesFileExist (fromNormalizedFilePath file)
99 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
102showTimePrecise :: UTCTime -> String
103showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
105getModificationTimeRule :: VFSHandle -> Rules ()
106getModificationTimeRule vfs =
107 defineEarlyCutoff $ \GetModificationTime file -> do
108 let file' = fromNormalizedFilePath file
109 let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just $ ModificationTime time))
110 alwaysRerun
111 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
112 case mbVirtual of
113 Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
114 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file')
115 `catch` \(e :: IOException) -> do
116 let err | isDoesNotExistError e = "File does not exist: " ++ file'
117 | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
118 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
121getFileContentsRule :: VFSHandle -> Rules ()
122getFileContentsRule vfs =
123 define $ \GetFileContents file -> do
124 -- need to depend on modification time to introduce a dependency with Cutoff
125 time <- use_ GetModificationTime file
126 res <- liftIO $ ideTryIOException file $ do
127 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
128 case mbVirtual of
129 Just (VirtualFile _ rope _) -> return $ textToStringBuffer $ Rope.toText rope
130 Nothing -> hGetStringBuffer (fromNormalizedFilePath file)
131 case res of
132 Left err -> return ([err], Nothing)
133 Right contents -> return ([], Just (time, contents))
135ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
136ideTryIOException fp act =
137 mapLeft
138 (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
139 <$> try act
142getFileContents :: NormalizedFilePath -> Action (FileVersion, StringBuffer)
143getFileContents = use_ GetFileContents
145getFileExists :: NormalizedFilePath -> Action Bool
146getFileExists =
147 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
148 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
149 -- cached 'No' rather than an exception in the wrong place
150 use_ GetFileExists
153fileStoreRules :: VFSHandle -> Rules ()
154fileStoreRules vfs = do
155 addIdeGlobal vfs
156 getModificationTimeRule vfs
157 getFileContentsRule vfs
158 getFileExistsRule vfs
161-- | Notify the compiler service of a modified buffer
162setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
163setBufferModified state absFile contents = do
164 VFSHandle{..} <- getIdeGlobalState state
165 setVirtualFileContents (filePathToUri' absFile) contents
166 void $ shakeRun state [] (const $ pure ())
169-- would be nice to do this more efficiently...
170textToStringBuffer :: T.Text -> SB.StringBuffer
171textToStringBuffer = SB.stringToStringBuffer . T.unpack