git.iko.soy/ghcide
on 163bbc9 help sign in
ghcide/src/Development/IDE/Core/FileStore.hs
175 lines 6.7 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 -> 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))
137ideTryIOException :: NormalizedFilePath -> IO a -> IO (Either FileDiagnostic a)
138ideTryIOException fp act =
139 mapLeft
140 (\(e :: IOException) -> ideErrorText fp $ T.pack $ show e)
141 <$> try act
144getFileContents :: NormalizedFilePath -> Action (FileVersion, StringBuffer)
145getFileContents = use_ GetFileContents
147getFileExists :: NormalizedFilePath -> Action Bool
148getFileExists =
149 -- we deliberately and intentionally wrap the file as an FilePath WITHOUT mkAbsolute
150 -- so that if the file doesn't exist, is on a shared drive that is unmounted etc we get a properly
151 -- cached 'No' rather than an exception in the wrong place
152 use_ GetFileExists
155fileStoreRules :: VFSHandle -> Rules ()
156fileStoreRules vfs = do
157 addIdeGlobal vfs
158 getModificationTimeRule vfs
159 getFileContentsRule vfs
160 getFileExistsRule vfs
163-- | Notify the compiler service of a modified buffer
164setBufferModified :: IdeState -> NormalizedFilePath -> Maybe T.Text -> IO ()
165setBufferModified state absFile mbContents = do
166 VFSHandle{..} <- getIdeGlobalState state
167 case mbContents of
168 Nothing -> removeVirtualFile (filePathToUri' absFile)
169 Just contents -> setVirtualFileContents (filePathToUri' absFile) contents
170 void $ shakeRun state [] (const $ pure ())
173-- would be nice to do this more efficiently...
174textToStringBuffer :: T.Text -> SB.StringBuffer
175textToStringBuffer = SB.stringToStringBuffer . T.unpack