7c3213c · ghcide · git.iko.soy

git.iko.soy/ghcide

on master help sign in

Use haskell-lsp’s builtin VFS in "damlc ide" (#1489)

7c3213cMoritz Kiefer7 years ago

BUILD.bazel+1

compare with master

unifiedsplit

@@ -20,6 +20,7 @@ depends = [

20 "haskell-lsp-types",

21 "mtl",

22 "pretty",

23+ "rope-utf16-splay",

23 "safe-exceptions",

24 "safe-exceptions",

24 "sorted-list",

25 "sorted-list",

25 "shake",

26 "shake",

src/Development/IDE/Functions/Compile.hs+11−8

@@ -55,7 +55,6 @@ import Data.List.Extra

55import Data.Maybe

56import Data.Tuple.Extra

57import qualified Data.Map.Strict as Map

58−import Data.Time

59import Development.IDE.Types.SpanInfo

58import Development.IDE.Types.SpanInfo

60import GHC.Generics (Generic)

59import GHC.Generics (Generic)

61import System.FilePath

60import System.FilePath

@@ -107,7 +106,7 @@ parseModule

107 :: IdeOptions

106 :: IdeOptions

108 -> HscEnv

107 -> HscEnv

109 -> FilePath

108 -> FilePath

110− -> (UTCTime, SB.StringBuffer)

109+ -> SB.StringBuffer

111 -> IO ([FileDiagnostic], Maybe ParsedModule)

110 -> IO ([FileDiagnostic], Maybe ParsedModule)

112parseModule opt@IdeOptions{..} packageState file =

111parseModule opt@IdeOptions{..} packageState file =

113 fmap (either (, Nothing) (second Just)) . Ex.runExceptT .

112 fmap (either (, Nothing) (second Just)) . Ex.runExceptT .

@@ -325,11 +324,11 @@ loadModuleHome tmr = modifySession $ \e ->

325getModSummaryFromBuffer

324getModSummaryFromBuffer

326 :: GhcMonad m

325 :: GhcMonad m

327 => FilePath

326 => FilePath

328− -> (SB.StringBuffer, UTCTime)

327+ -> SB.StringBuffer

329 -> DynFlags

328 -> DynFlags

330 -> GHC.ParsedSource

329 -> GHC.ParsedSource

331 -> Ex.ExceptT [FileDiagnostic] m ModSummary

330 -> Ex.ExceptT [FileDiagnostic] m ModSummary

332−getModSummaryFromBuffer fp (contents, fileDate) dflags parsed = do

331+getModSummaryFromBuffer fp contents dflags parsed = do

333 (modName, imports) <- FindImports.getImportsParsed dflags parsed

332 (modName, imports) <- FindImports.getImportsParsed dflags parsed

334

333

335 let modLoc = ModLocation

334 let modLoc = ModLocation

@@ -347,7 +346,11 @@ getModSummaryFromBuffer fp (contents, fileDate) dflags parsed = do

347 return $ ModSummary

346 return $ ModSummary

348 { ms_mod = mkModule (fsToUnitId unitId) modName

347 { ms_mod = mkModule (fsToUnitId unitId) modName

349 , ms_location = modLoc

348 , ms_location = modLoc

350− , ms_hs_date = fileDate

349+ , ms_hs_date = error "Rules should not depend on ms_hs_date"

350+ -- ^ When we are working with a virtual file we do not have a file date.

351+ -- To avoid silent issues where something is not processed because the date

352+ -- has not changed, we make sure that things blow up if they depend on the

353+ -- date.

351 , ms_textual_imps = imports

354 , ms_textual_imps = imports

352 , ms_hspp_file = fp

355 , ms_hspp_file = fp

353 , ms_hspp_opts = dflags

356 , ms_hspp_opts = dflags

@@ -370,9 +373,9 @@ parseFileContents

370 :: GhcMonad m

373 :: GhcMonad m

371 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))

374 => (GHC.ParsedSource -> ([(GHC.SrcSpan, String)], GHC.ParsedSource))

372 -> FilePath -- ^ the filename (for source locations)

375 -> FilePath -- ^ the filename (for source locations)

373− -> (UTCTime, SB.StringBuffer) -- ^ Haskell module source text (full Unicode is supported)

376+ -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)

374 -> Ex.ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

377 -> Ex.ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

375−parseFileContents preprocessor filename (time, contents) = do

378+parseFileContents preprocessor filename contents = do

376 let loc = mkRealSrcLoc (mkFastString filename) 1 1

379 let loc = mkRealSrcLoc (mkFastString filename) 1 1

377 dflags <- parsePragmasIntoDynFlags filename contents

380 dflags <- parsePragmasIntoDynFlags filename contents

378

381

@@ -422,7 +425,7 @@ parseFileContents preprocessor filename (time, contents) = do

422 -- Ok, we got here. It's safe to continue.

425 -- Ok, we got here. It's safe to continue.

423 let (errs, parsed) = preprocessor rdr_module

426 let (errs, parsed) = preprocessor rdr_module

424 unless (null errs) $ Ex.throwE $ mkErrors dflags errs

427 unless (null errs) $ Ex.throwE $ mkErrors dflags errs

425− ms <- getModSummaryFromBuffer filename (contents, time) dflags parsed

428+ ms <- getModSummaryFromBuffer filename contents dflags parsed

426 let pm =

429 let pm =

427 ParsedModule {

430 ParsedModule {

428 pm_mod_summary = ms

431 pm_mod_summary = ms

src/Development/IDE/State/FileStore.hs+70−47

@@ -6,7 +6,10 @@

6module Development.IDE.State.FileStore(

7 getFileExists, getFileContents,

8 setBufferModified,

9− fileStoreRules

9+ fileStoreRules,

10+ VFSHandle(..),

11+ makeVFSHandle,

12+ makeLSPVFSHandle,

10 ) where

13 ) where

@@ -14,7 +17,9 @@ module Development.IDE.State.FileStore(

14import StringBuffer

17import StringBuffer

15import Development.IDE.Orphans()

18import Development.IDE.Orphans()

20+import Control.Concurrent.Extra

17import qualified Data.Map.Strict as Map

21import qualified Data.Map.Strict as Map

22+import Data.Maybe

18import qualified Data.Text as T

23import qualified Data.Text as T

19import Data.Time.Clock

24import Data.Time.Clock

20import Control.Monad.Extra

25import Control.Monad.Extra

@@ -22,28 +27,54 @@ import qualified System.Directory as Dir

22import Development.Shake

27import Development.Shake

23import Development.Shake.Classes

28import Development.Shake.Classes

24import Development.IDE.State.Shake

29import Development.IDE.State.Shake

25−import Control.Concurrent.Extra

26import Control.Exception

30import Control.Exception

27import GHC.Generics

31import GHC.Generics

28import System.IO.Error

32import System.IO.Error

29import qualified Data.ByteString.Char8 as BS

33import qualified Data.ByteString.Char8 as BS

30import qualified StringBuffer as SB

34import qualified StringBuffer as SB

31import Development.IDE.Types.Diagnostics

35import Development.IDE.Types.Diagnostics

36+import qualified Data.Rope.UTF16 as Rope

32import Data.Time

37import Data.Time

34−

39+import Language.Haskell.LSP.Core

35−-- This module stores the changed files in memory, and answers file system questions

40+import Language.Haskell.LSP.VFS

36−-- from either the memory changes OR the file system itself

41+

37−

42+-- | haskell-lsp manages the VFS internally and automatically so we cannot use

38−type DirtyFiles = Map.Map FilePath (UTCTime, StringBuffer) -- when it was modified, it's current value

43+-- the builtin VFS without spawning up an LSP server. To be able to test things

39−

44+-- like `setBufferModified` we abstract over the VFS implementation.

40−-- Store the DirtyFiles globally, so we can get at it through setBufferModified

45+data VFSHandle = VFSHandle

41−newtype GlobalDirtyFiles = GlobalDirtyFiles (Var DirtyFiles)

46+ { getVirtualFile :: Uri -> IO (Maybe VirtualFile)

47+ , setVirtualFileContents :: Uri -> T.Text -> IO ()

48+ , removeVirtualFile :: Uri -> IO ()

49+ }

50+

42−instance IsIdeGlobal GlobalDirtyFiles

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+ }

45-- | Get the contents of a file, either dirty (if the buffer is modified) or from disk.

76-- | 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)

48-- | Does the file exist.

79-- | Does the file exist.

49type instance RuleResult GetFileExists = Bool

80type instance RuleResult GetFileExists = Bool

@@ -60,12 +91,12 @@ instance Hashable GetFileContents

60instance NFData GetFileContents

91instance NFData GetFileContents

63−getFileExistsRule :: Var DirtyFiles -> Rules ()

94+getFileExistsRule :: VFSHandle -> Rules ()

64−getFileExistsRule dirty =

95+getFileExistsRule vfs =

65 defineEarlyCutoff $ \GetFileExists file -> do

96 defineEarlyCutoff $ \GetFileExists file -> do

66 alwaysRerun

97 alwaysRerun

67 res <- liftIO $ handle (\(_ :: IOException) -> return False) $

98 res <- liftIO $ handle (\(_ :: IOException) -> return False) $

68− (Map.member file <$> readVar dirty) ||^

99+ (isJust <$> getVirtualFile vfs (filePathToUri file)) ||^

69 Dir.doesFileExist file

100 Dir.doesFileExist file

70 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))

101 return (Just $ if res then BS.singleton '1' else BS.empty, ([], Just res))

102

@@ -73,36 +104,36 @@ getFileExistsRule dirty =

73showTimePrecise :: UTCTime -> String

104showTimePrecise :: UTCTime -> String

74showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)

105showTimePrecise UTCTime{..} = show (toModifiedJulianDay utctDay, diffTimeToPicoseconds utctDayTime)

106

76−getModificationTimeRule :: Var DirtyFiles -> Rules ()

107+getModificationTimeRule :: VFSHandle -> Rules ()

77−getModificationTimeRule dirty =

108+getModificationTimeRule vfs =

78 defineEarlyCutoff $ \GetModificationTime file -> do

109 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))

80 alwaysRerun

111 alwaysRerun

81− mp <- liftIO $ readVar dirty

112+ mbVirtual <- liftIO $ getVirtualFile vfs $ filePathToUri file

82− case Map.lookup file mp of

113+ case mbVirtual of

83− Just (time, _) -> return $ wrap time

114+ Just (VirtualFile ver _ _) -> pure (Just $ BS.pack $ show ver, ([], Just $ VFSVersion ver))

84 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do

115 Nothing -> liftIO $ fmap wrap (Dir.getModificationTime file) `catch` \(e :: IOException) -> do

85 let err | isDoesNotExistError e = "File does not exist: " ++ file

116 let err | isDoesNotExistError e = "File does not exist: " ++ file

86 | otherwise = "IO error while reading " ++ file ++ ", " ++ displayException e

117 | otherwise = "IO error while reading " ++ file ++ ", " ++ displayException e

87 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))

118 return (Nothing, ([ideErrorText file $ T.pack err], Nothing))

119

120

90−getFileContentsRule :: Var DirtyFiles -> Rules ()

121+getFileContentsRule :: VFSHandle -> Rules ()

91−getFileContentsRule dirty =

122+getFileContentsRule vfs =

92 define $ \GetFileContents file -> do

123 define $ \GetFileContents file -> do

93 -- need to depend on modification time to introduce a dependency with Cutoff

124 -- need to depend on modification time to introduce a dependency with Cutoff

94 time <- use_ GetModificationTime file

125 time <- use_ GetModificationTime file

95 res <- liftIO $ ideTryIOException file $ do

126 res <- liftIO $ ideTryIOException file $ do

96− mp <- readVar dirty

127+ mbVirtual <- getVirtualFile vfs $ filePathToUri file

97− case Map.lookup file mp of

128+ case mbVirtual of

98− Just (_, contents) -> return contents

129+ Just (VirtualFile _ rope _) -> return $ textToStringBuffer $ Rope.toText rope

99 Nothing -> hGetStringBuffer file

130 Nothing -> hGetStringBuffer file

100 case res of

131 case res of

101 Left err -> return ([err], Nothing)

132 Left err -> return ([err], Nothing)

102 Right contents -> return ([], Just (time, contents))

133 Right contents -> return ([], Just (time, contents))

103

134

104

135

105−getFileContents :: FilePath -> Action (UTCTime, StringBuffer)

136+getFileContents :: FilePath -> Action (FileVersion, StringBuffer)

106getFileContents = use_ GetFileContents

137getFileContents = use_ GetFileContents

107

138

108getFileExists :: FilePath -> Action Bool

139getFileExists :: FilePath -> Action Bool

@@ -113,29 +144,21 @@ getFileExists =

113 use_ GetFileExists

144 use_ GetFileExists

114

145

115

146

116−fileStoreRules :: Rules ()

147+fileStoreRules :: VFSHandle -> Rules ()

117−fileStoreRules = do

148+fileStoreRules vfs = do

118− dirty <- liftIO $ newVar Map.empty

119− addIdeGlobal $ GlobalDirtyFiles dirty

149+ addIdeGlobal vfs

120− getModificationTimeRule dirty

150+ getModificationTimeRule vfs

121− getFileContentsRule dirty

151+ getFileContentsRule vfs

122− getFileExistsRule dirty

152+ getFileExistsRule vfs

123−

124−

125−strictPair :: a -> b -> (a, b)

126−strictPair !a !b = (a,b)

127

153

128

154

129-- | Notify the compiler service of a modified buffer

155-- | Notify the compiler service of a modified buffer

130−setBufferModified :: IdeState -> FilePath -> (Maybe T.Text, UTCTime) -> IO ()

156+setBufferModified :: IdeState -> FilePath -> Maybe T.Text -> IO ()

131−setBufferModified state absFile (mcontents, !time) = do

157+setBufferModified state absFile mbContents = do

132− GlobalDirtyFiles envDirtyFiles <- getIdeGlobalState state

158+ VFSHandle{..} <- getIdeGlobalState state

133− -- update vars synchronously

159+ case mbContents of

134− modifyVar_ envDirtyFiles $ evaluate . case mcontents of

135− Nothing -> Map.delete absFile

160+ Nothing -> removeVirtualFile (filePathToUri absFile)

136− Just contents -> Map.insert absFile $ strictPair time $ textToStringBuffer contents

161+ Just contents -> setVirtualFileContents (filePathToUri absFile) contents

137−

138− -- run shake to update results regarding the files of interest

139 void $ shakeRun state []

162 void $ shakeRun state []

140

163

141

164

src/Development/IDE/State/Rules.hs+1−1

@@ -164,7 +164,7 @@ data Priority

164getParsedModuleRule :: Rules ()

165getParsedModuleRule =

166 define $ \GetParsedModule file -> do

167− contents <- getFileContents file

167+ (_, contents) <- getFileContents file

168 packageState <- use_ GhcSession ""

169 opt <- getOpts

170 liftIO $ Compile.parseModule opt packageState file contents

src/Development/IDE/State/Service.hs+3−2

@@ -73,8 +73,9 @@ initialise :: Rules ()

73 -> Maybe (Event -> IO ())

74 -> Logger.Handle

75 -> IdeOptions

76+ -> VFSHandle

76 -> IO IdeState

77 -> IO IdeState

77−initialise mainRule toDiags logger options =

78+initialise mainRule toDiags logger options vfs =

78 shakeOpen

79 shakeOpen

79 (fromMaybe (const $ pure ()) toDiags)

80 (fromMaybe (const $ pure ()) toDiags)

80 logger

81 logger

@@ -83,7 +84,7 @@ initialise mainRule toDiags logger options =

83 , shakeFiles = "/dev/null"

84 , shakeFiles = "/dev/null"

84 }) $ do

85 }) $ do

85 addIdeGlobal =<< liftIO (mkEnv options)

86 addIdeGlobal =<< liftIO (mkEnv options)

86− fileStoreRules

87+ fileStoreRules vfs

87 mainRule

88 mainRule

89writeProfile :: IdeState -> FilePath -> IO ()

90writeProfile :: IdeState -> FilePath -> IO ()

src/Development/IDE/State/Shake.hs+13−2

@@ -40,6 +40,8 @@ module Development.IDE.State.Shake(

40 sendEvent,

41 Development.IDE.State.Shake.logDebug,

42 Development.IDE.State.Shake.logSeriousError,

43+ FileVersion(..),

44+ vfsVersion

43 ) where

45 ) where

45import Development.Shake

47import Development.Shake

@@ -390,7 +392,7 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do

390 modTime <- join <$> getValues state GetModificationTime fp

392 modTime <- join <$> getValues state GetModificationTime fp

391 modifyVar diagnostics $ \old -> do

393 modifyVar diagnostics $ \old -> do

392 let oldDiags = getFileDiagnostics fp old

394 let oldDiags = getFileDiagnostics fp old

393− let newDiagsStore = setStageDiagnostics fp modTime k current old

395+ let newDiagsStore = setStageDiagnostics fp (vfsVersion =<< modTime) k current old

394 let newDiags = getFileDiagnostics fp newDiagsStore

396 let newDiags = getFileDiagnostics fp newDiagsStore

395 pure (newDiagsStore, (newDiags, oldDiags))

397 pure (newDiagsStore, (newDiags, oldDiags))

396 when (newDiags /= oldDiags) $

398 when (newDiags /= oldDiags) $

@@ -421,4 +423,13 @@ instance Hashable GetModificationTime

421instance NFData GetModificationTime

423instance NFData GetModificationTime

422

424

423-- | Get the modification time of a file.

425-- | Get the modification time of a file.

424−type instance RuleResult GetModificationTime = UTCTime

426+type instance RuleResult GetModificationTime = FileVersion

427+

428+data FileVersion = VFSVersion Int | ModificationTime UTCTime

429+ deriving (Show, Generic)

430+

431+instance NFData FileVersion

432+

433+vfsVersion :: FileVersion -> Maybe Int

434+vfsVersion (VFSVersion i) = Just i

435+vfsVersion (ModificationTime _) = Nothing

src/Development/IDE/Types/Diagnostics.hs+2−6

@@ -44,8 +44,6 @@ import Data.Either.Combinators

44import Data.Maybe as Maybe

45import Data.Foldable

46import qualified Data.Map as Map

47−import Data.Time.Clock

48−import Data.Time.Clock.POSIX

49import qualified Data.Text as T

47import qualified Data.Text as T

50import Data.Text.Prettyprint.Doc.Syntax

48import Data.Text.Prettyprint.Doc.Syntax

51import qualified Data.SortedList as SL

49import qualified Data.SortedList as SL

@@ -179,18 +177,16 @@ emptyDiagnostics = ProjectDiagnostics mempty

179setStageDiagnostics ::

177setStageDiagnostics ::

180 Show stage =>

178 Show stage =>

181 FilePath ->

179 FilePath ->

182− Maybe UTCTime ->

180+ Maybe Int ->

183 -- ^ the time that the file these diagnostics originate from was last edited

181 -- ^ the time that the file these diagnostics originate from was last edited

184 stage ->

182 stage ->

185 [LSP.Diagnostic] ->

183 [LSP.Diagnostic] ->

186 ProjectDiagnostics stage ->

184 ProjectDiagnostics stage ->

187 ProjectDiagnostics stage

185 ProjectDiagnostics stage

188setStageDiagnostics fp timeM stage diags (ProjectDiagnostics ds) =

186setStageDiagnostics fp timeM stage diags (ProjectDiagnostics ds) =

189− ProjectDiagnostics $ updateDiagnostics ds uri posixTime diagsBySource

187+ ProjectDiagnostics $ updateDiagnostics ds uri timeM diagsBySource

190 where

188 where

191 diagsBySource = Map.singleton (Just $ T.pack $ show stage) (SL.toSortedList diags)

189 diagsBySource = Map.singleton (Just $ T.pack $ show stage) (SL.toSortedList diags)

192− posixTime :: Maybe Int

193− posixTime = fmap (fromEnum . utcTimeToPOSIXSeconds) timeM

194 uri = filePathToUri fp

190 uri = filePathToUri fp

195

191

196fromUri :: LSP.Uri -> FilePath

192fromUri :: LSP.Uri -> FilePath

test/Demo.hs+3

@@ -6,6 +6,7 @@ module Demo(main) where

6import Control.Concurrent.Extra

7import Control.Monad

8import System.Time.Extra

9+import Development.IDE.State.FileStore

9import Development.IDE.State.Service

10import Development.IDE.State.Service

10import Development.IDE.State.Rules

11import Development.IDE.State.Rules

11import Development.IDE.State.Shake

12import Development.IDE.State.Shake

@@ -38,6 +39,7 @@ main = do

38 -- lock to avoid overlapping output on stdout

39 -- lock to avoid overlapping output on stdout

39 lock <- newLock

40 lock <- newLock

42+ vfs <- makeVFSHandle

41 ide <- initialise

43 ide <- initialise

42 mainRule

44 mainRule

43 (Just $ showEvent lock)

45 (Just $ showEvent lock)

@@ -51,6 +53,7 @@ main = do

51 ,optThreads = 0

53 ,optThreads = 0

52 ,optShakeProfiling = Nothing -- Just "output.html"

54 ,optShakeProfiling = Nothing -- Just "output.html"

53 }

55 }

56+ vfs

54 setFilesOfInterest ide $ Set.fromList files

57 setFilesOfInterest ide $ Set.fromList files

55 _ <- runAction ide $ uses_ TypeCheck files

58 _ <- runAction ide $ uses_ TypeCheck files

56 -- shake now writes an async message that it is completed with timing info,

59 -- shake now writes an async message that it is completed with timing info,