@@ -6,7 +6,10 @@
66module Development.IDE.State.FileStore(
77 getFileExists, getFileContents,
88 setBufferModified,
9− fileStoreRules
9+ fileStoreRules,
10+ VFSHandle(..),
11+ makeVFSHandle,
12+ makeLSPVFSHandle,
1013 ) where
1114
1215
@@ -14,7 +17,9 @@ module Development.IDE.State.FileStore(
1417import StringBuffer
1518import Development.IDE.Orphans()
1619
20+import Control.Concurrent.Extra
1721import qualified Data.Map.Strict as Map
22+import Data.Maybe
1823import qualified Data.Text as T
1924import Data.Time.Clock
2025import Control.Monad.Extra
@@ -22,28 +27,54 @@ import qualified System.Directory as Dir
2227import Development.Shake
2328import Development.Shake.Classes
2429import Development.IDE.State.Shake
25−import Control.Concurrent.Extra
2630import Control.Exception
2731import GHC.Generics
2832import System.IO.Error
2933import qualified Data.ByteString.Char8 as BS
3034import qualified StringBuffer as SB
3135import Development.IDE.Types.Diagnostics
36+import qualified Data.Rope.UTF16 as Rope
3237import Data.Time
3338
34−
35−-- This module stores the changed files in memory, and answers file system questions
36−-- from either the memory changes OR the file system itself
37−
38−type DirtyFiles = Map.Map FilePath (UTCTime, StringBuffer) -- when it was modified, it's current value
39−
40−-- Store the DirtyFiles globally, so we can get at it through setBufferModified
41−newtype GlobalDirtyFiles = GlobalDirtyFiles (Var DirtyFiles)
42−instance IsIdeGlobal GlobalDirtyFiles
39+import Language.Haskell.LSP.Core
40+import Language.Haskell.LSP.VFS
41+
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.
45+data VFSHandle = VFSHandle
46+ { getVirtualFile :: Uri -> IO (Maybe VirtualFile)
47+ , setVirtualFileContents :: Uri -> T.Text -> IO ()
48+ , removeVirtualFile :: Uri -> IO ()
49+ }
50+
51+instance IsIdeGlobal VFSHandle
52+
53+makeVFSHandle :: IO VFSHandle
54+makeVFSHandle = 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+ }
65+
66+makeLSPVFSHandle :: LspFuncs c -> VFSHandle
67+makeLSPVFSHandle 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+ }
4374
4475
4576-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.
46−type instance RuleResult GetFileContents = (UTCTime, StringBuffer)
77+type instance RuleResult GetFileContents = (FileVersion, StringBuffer)
4778
4879-- | Does the file exist.
4980type instance RuleResult GetFileExists = Bool
@@ -60,12 +91,12 @@ instance Hashable GetFileContents
6091instance NFData GetFileContents
6192
6293
63−getFileExistsRule :: Var DirtyFiles -> Rules ()
64−getFileExistsRule dirty =
94+getFileExistsRule :: VFSHandle -> Rules ()
95+getFileExistsRule vfs =
6596 defineEarlyCutoff $ \GetFileExists file -> do
6697 alwaysRerun
6798 res <- liftIO $ handle (\(_ :: IOException) -> return False) $
68− (Map.member file <$> readVar dirty) ||^
99+ (isJust <$> getVirtualFile vfs (filePathToUri file)) ||^
69100 Dir.doesFileExist file
70101 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))
71102
@@ -73,36 +104,36 @@ getFileExistsRule dirty =
73104showTimePrecise :: UTCTime -> String
74105showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)
75106
76−getModificationTimeRule :: Var DirtyFiles -> Rules ()
77−getModificationTimeRule dirty =
107+getModificationTimeRule :: VFSHandle -> Rules ()
108+getModificationTimeRule vfs =
78109 defineEarlyCutoff $ \GetModificationTime file -> do
79− let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just time))
110+ let wrap time = (Just $ BS.pack $ showTimePrecise time, ([], Just $ ModificationTime time))
80111 alwaysRerun
81− mp <- liftIO $ readVar dirty
82− case Map.lookup file mp of
83− Just (time, _) -> return $ wrap time
112+ mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri file
113+ case mbVirtual of
114+ Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))
84115 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do
85116 let err | isDoesNotExistError e = "File does not exist: " ++ file
86117 | otherwise = "IO error while reading " ++ file ++ ", " ++ displayException e
87118 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))
88119
89120
90−getFileContentsRule :: Var DirtyFiles -> Rules ()
91−getFileContentsRule dirty =
121+getFileContentsRule :: VFSHandle -> Rules ()
122+getFileContentsRule vfs =
92123 define $ \GetFileContents file -> do
93124 -- need to depend on modification time to introduce a dependency with Cutoff
94125 time <- use_ GetModificationTime file
95126 res <- liftIO $ ideTryIOException file $ do
96− mp <- readVar dirty
97− case Map.lookup file mp of
98− Just (_, contents) -> return contents
127+ mbVirtual <- getVirtualFile vfs $ filePathToUri file
128+ case mbVirtual of
129+ Just (VirtualFile _ rope _) -> return $ textToStringBuffer $ Rope.toText rope
99130 Nothing -> hGetStringBuffer file
100131 case res of
101132 Left err -> return ([err], Nothing)
102133 Right contents -> return ([], Just (time, contents))
103134
104135
105−getFileContents :: FilePath -> Action (UTCTime, StringBuffer)
136+getFileContents :: FilePath -> Action (FileVersion, StringBuffer)
106137getFileContents = use_ GetFileContents
107138
108139getFileExists :: FilePath -> Action Bool
@@ -113,29 +144,21 @@ getFileExists =
113144 use_ GetFileExists
114145
115146
116−fileStoreRules :: Rules ()
117−fileStoreRules = do
118− dirty <- liftIO $ newVar Map.empty
119− addIdeGlobal $ GlobalDirtyFiles dirty
120− getModificationTimeRule dirty
121− getFileContentsRule dirty
122− getFileExistsRule dirty
123−
124−
125−strictPair :: a -> b -> (a, b)
126−strictPair !a !b = (a,b)
147+fileStoreRules :: VFSHandle -> Rules ()
148+fileStoreRules vfs = do
149+ addIdeGlobal vfs
150+ getModificationTimeRule vfs
151+ getFileContentsRule vfs
152+ getFileExistsRule vfs
127153
128154
129155-- | Notify the compiler service of a modified buffer
130−setBufferModified :: IdeState -> FilePath -> (Maybe T.Text, UTCTime) -> IO ()
131−setBufferModified state absFile (mcontents, !time) = do
132− GlobalDirtyFiles envDirtyFiles <- getIdeGlobalState state
133− -- update vars synchronously
134− modifyVar_ envDirtyFiles $ evaluate . case mcontents of
135− Nothing -> Map.delete absFile
136− Just contents -> Map.insert absFile $ strictPair time $ textToStringBuffer contents
137−
138− -- run shake to update results regarding the files of interest
156+setBufferModified :: IdeState -> FilePath -> Maybe T.Text -> IO ()
157+setBufferModified state absFile mbContents = do
158+ VFSHandle{..} <- getIdeGlobalState state
159+ case mbContents of
160+ Nothing -> removeVirtualFile (filePathToUri absFile)
161+ Just contents -> setVirtualFileContents (filePathToUri absFile) contents
139162 void $ shakeRun state []
140163
141164