git.iko.soy/ghcide
on 210de4e help sign in
ghcide/src/Development/IDE/State/FileStore.hs
169 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.State.FileStore(
7 getFileExists, getFileContents,
8 setBufferModified,
9 fileStoreRules,
10 VFSHandle(..),
11 makeVFSHandle,
12 makeLSPVFSHandle,
13 ) where
17import StringBuffer
18import Development.IDE.Orphans()
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.State.Shake
30import Control.Exception
31import GHC.Generics
32import System.IO.Error
33import qualified Data.ByteString.Char8 as BS
34import qualified StringBuffer as SB
35import Development.IDE.Types.Diagnostics
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 -> T.Text -> IO ()
48 , removeVirtualFile :: NormalizedUri -> IO ()
49 }
51instance IsIdeGlobal VFSHandle
53makeVFSHandle :: IO VFSHandle
54makeVFSHandle = do
55 vfsVar <- newVar (1, Map.empty)
56 pure VFSHandle
57 { getVirtualFile = \uri -> do
58 (_nextVersion, vfs) <- readVar vfsVar
59 pure $ Map.lookup uri vfs
60 , setVirtualFileContents = \uri content ->
61 modifyVar_ vfsVar $ \(nextVersion, vfs) ->
62 pure (nextVersion + 1, Map.insert uri (VirtualFile nextVersion (Rope.fromText content) Nothing) vfs)
63 , removeVirtualFile = \uri -> modifyVar_ vfsVar $ \(nextVersion, vfs) -> pure (nextVersion, Map.delete uri vfs)
64 }
66makeLSPVFSHandle :: LspFuncs c -> VFSHandle
67makeLSPVFSHandle lspFuncs = VFSHandle
68 { getVirtualFile = getVirtualFileFunc lspFuncs
69 , setVirtualFileContents = \_ _ -> pure ()
70 -- ^ Handled internally by haskell-lsp.
71 , removeVirtualFile = \_ -> pure ()
72 -- ^ Handled internally by haskell-lsp.
73 }
76-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.
77type instance RuleResult GetFileContents = (FileVersion, StringBuffer)
79-- | Does the file exist.
80type instance RuleResult GetFileExists = Bool
83data GetFileExists = GetFileExists
84 deriving (Eq, Show, Generic)
85instance Hashable GetFileExists
86instance NFData GetFileExists
88data GetFileContents = GetFileContents
89 deriving (Eq, Show, Generic)
90instance Hashable GetFileContents
91instance NFData GetFileContents
94getFileExistsRule :: VFSHandle -> Rules ()
95getFileExistsRule vfs =
96 defineEarlyCutoff $ \GetFileExists file -> do
97 alwaysRerun
98 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
99 (isJust <$> getVirtualFile vfs (filePathToUri' file)) ||^
100 Dir.doesFileExist (fromNormalizedFilePath file)
101 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
104showTimePrecise :: UTCTime -> String
105showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
107getModificationTimeRule :: VFSHandle -> Rules ()
108getModificationTimeRule vfs =
109 defineEarlyCutoff $ \GetModificationTime file -> do
110 let file' = fromNormalizedFilePath file
111 let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just $ ModificationTime time))
112 alwaysRerun
113 mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri' file
114 case mbVirtual of
115 Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
116 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file')
117 `catch` \(e :: IOException) -> do
118 let err | isDoesNotExistError e = "File does not exist: " ++ file'
119 | otherwise = "IO error while reading " ++ file' ++ ", " ++ displayException e
120 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
123getFileContentsRule :: VFSHandle -> Rules ()
124getFileContentsRule vfs =
125 define $ \GetFileContents file -> do
126 -- need to depend on modification time to introduce a dependency with Cutoff
127 time <- use_ GetModificationTime file
128 res <- liftIO $ ideTryIOException file $ do
129 mbVirtual <- getVirtualFile vfs $ filePathToUri' file
130 case mbVirtual of
131 Just (VirtualFile _ rope _) -> return $ textToStringBuffer $ Rope.toText rope
132 Nothing -> hGetStringBuffer (fromNormalizedFilePath file)
133 case res of
134 Left err -> return ([err], Nothing)
135 Right contents -> return ([], Just (time, contents))
138getFileContents :: NormalizedFilePath -> Action (FileVersion, StringBuffer)
139getFileContents = use_ GetFileContents
141getFileExists :: NormalizedFilePath -> Action Bool
142getFileExists =
143 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
144 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
145 -- cached 'No' rather than an exception in the wrong place
146 use_ GetFileExists
149fileStoreRules :: VFSHandle -> Rules ()
150fileStoreRules vfs = do
151 addIdeGlobal vfs
152 getModificationTimeRule vfs
153 getFileContentsRule vfs
154 getFileExistsRule vfs
157-- | Notify the compiler service of a modified buffer
158setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
159setBufferModified state absFile mbContents = do
160 VFSHandle{..} <- getIdeGlobalState state
161 case mbContents of
162 Nothing -> removeVirtualFile (filePathToUri' absFile)
163 Just contents -> setVirtualFileContents (filePathToUri' absFile) contents
164 void $ shakeRun state []
167-- would be nice to do this more efficiently...
168textToStringBuffer :: T.Text -> SB.StringBuffer
169textToStringBuffer = SB.stringToStringBuffer . T.unpack