f70eece · ghcide · git.iko.soy

src/Development/IDE/Core/Compile.hs+45−10

compare with master

unifiedsplit

@@ -58,6 +58,7 @@ import Development.IDE.Spans.Type

58import System.FilePath

59import System.Directory

60import System.IO.Extra

61+import Data.Char

61

62

63

63-- | Contains the typechecked module and the OrigNameCache entry for

64-- | Contains the typechecked module and the OrigNameCache entry for

@@ -91,7 +92,7 @@ parseModule

91 :: IdeOptions

92 :: IdeOptions

92 -> HscEnv

93 -> HscEnv

93 -> FilePath

94 -> FilePath

94− -> SB.StringBuffer

95+ -> Maybe SB.StringBuffer

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

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

96parseModule IdeOptions{..} env file =

97parseModule IdeOptions{..} env file =

97 fmap (either (, Nothing) (second Just)) .

98 fmap (either (, Nothing) (second Just)) .

@@ -310,15 +311,55 @@ getModSummaryFromBuffer fp contents dflags parsed = do

310 , ms_parsed_mod = Nothing

311 , ms_parsed_mod = Nothing

311 }

312 }

312

313

314+-- | Run CPP on a file

315+runCpp :: DynFlags -> FilePath -> Maybe SB.StringBuffer -> IO SB.StringBuffer

316+runCpp dflags filename contents = withTempDir $ \dir -> do

317+ let out = dir </> takeFileName filename <.> "out"

318+ case contents of

319+ Nothing -> do

320+ -- Happy case, file is not modified, so run CPP on it in-place

321+ -- which also makes things like relative #include files work

322+ -- and means location information is correct

323+ doCpp dflags True filename out

324+ liftIO $ SB.hGetStringBuffer out

325+

326+ Just contents -> do

327+ -- Sad path, we have to create a version of the path in a temp dir

328+ -- __FILE__ macro is wrong, ignoring that for now (likely not a real issue)

329+

330+ -- Relative includes aren't going to work, so we fix that by adding to the include path.

331+ let addSelf (IncludeSpecs quote global) = IncludeSpecs (takeDirectory filename : quote) global

332+ dflags <- return dflags{includePaths = addSelf $ includePaths dflags}

333+

334+ -- Location information is wrong, so we fix that by patching it afterwards.

335+ let inp = dir </> "___HIE_CORE_MAGIC___"

336+ withBinaryFile inp WriteMode $ \h ->

337+ hPutStringBuffer h contents

338+ doCpp dflags True inp out

339+

340+ -- Fix up the filename in lines like:

341+ -- # 1 "C:/Temp/extra-dir-914611385186/___HIE_CORE_MAGIC___"

342+ let tweak x

343+ | Just x <- stripPrefix "# " x

344+ , "___HIE_CORE_MAGIC___" `isInfixOf` x

345+ , let num = takeWhile (not . isSpace) x

346+ -- important to use /, and never \ for paths, even on Windows, since then C escapes them

347+ -- and GHC gets all confused

348+ = "# " <> num <> " \"" <> map (\x -> if isPathSeparator x then '/' else x) filename <> "\""

349+ | otherwise = x

350+ stringToStringBuffer . unlines . map tweak . lines <$> readFileUTF8' out

351+

352+

313-- | Given a buffer, flags, file path and module summary, produce a

353-- | Given a buffer, flags, file path and module summary, produce a

314-- parsed module (or errors) and any parse warnings.

354-- parsed module (or errors) and any parse warnings.

315parseFileContents

355parseFileContents

316 :: GhcMonad m

356 :: GhcMonad m

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

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

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

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

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

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

320 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

360 -> ExceptT [FileDiagnostic] m ([FileDiagnostic], ParsedModule)

321−parseFileContents preprocessor filename contents = do

361+parseFileContents preprocessor filename mbContents = do

362+ contents <- liftIO $ maybe (hGetStringBuffer filename) return mbContents

322 let loc = mkRealSrcLoc (mkFastString filename) 1 1

363 let loc = mkRealSrcLoc (mkFastString filename) 1 1

323 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

364 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

324

365

@@ -326,13 +367,7 @@ parseFileContents preprocessor filename contents = do

326 if not $ xopt LangExt.Cpp dflags then

367 if not $ xopt LangExt.Cpp dflags then

327 return (contents, dflags)

368 return (contents, dflags)

328 else do

369 else do

329− contents <- liftIO $ withTempDir $ \dir -> do

370+ contents <- liftIO $ runCpp dflags filename mbContents

330− let inp = dir </> takeFileName filename

331− let out = dir </> takeFileName filename <.> "out"

332− let f x = if SB.atEnd x then Nothing else Just $ SB.nextChar x

333− liftIO $ writeFileUTF8 inp (unfoldr f contents)

334− doCpp dflags True inp out

335− liftIO $ SB.hGetStringBuffer out

336 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

371 dflags <- ExceptT $ parsePragmasIntoDynFlags filename contents

337 return (contents, dflags)

372 return (contents, dflags)

338

373

src/Development/IDE/Core/FileStore.hs+5−12

@@ -15,6 +15,7 @@ module Development.IDE.Core.FileStore(

15

16import StringBuffer

17import Development.IDE.GHC.Orphans()

18+import Development.IDE.GHC.Util

18

19

19import Control.Concurrent.Extra

20import Control.Concurrent.Extra

20import qualified Data.Map.Strict as Map

21import qualified Data.Map.Strict as Map

@@ -31,7 +32,6 @@ import GHC.Generics

31import Data.Either.Extra

32import Data.Either.Extra

32import System.IO.Error

33import System.IO.Error

33import qualified Data.ByteString.Char8 as BS

34import qualified Data.ByteString.Char8 as BS

34−import qualified StringBuffer as SB

35import Development.IDE.Types.Diagnostics

36import Development.IDE.Types.Location

37import qualified Data.Rope.UTF16 as Rope

@@ -74,8 +74,8 @@ makeLSPVFSHandle lspFuncs = VFSHandle

74 }

75

76

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

77+-- | Get the contents of a file, either dirty (if the buffer is modified) or Nothing to mean use from disk.

78−type instance RuleResult GetFileContents = (FileVersion, StringBuffer)

78+type instance RuleResult GetFileContents = (FileVersion, Maybe StringBuffer)

79

80-- | Does the file exist.

81type instance RuleResult GetFileExists = Bool

@@ -128,9 +128,7 @@ getFileContentsRule vfs =

128 time <- use_ GetModificationTime file

129 res <- liftIO $ ideTryIOException file $ do

130 mbVirtual <- getVirtualFile vfs $ filePathToUri' file

131− case mbVirtual of

132− Just (VirtualFile _ rope _) -> return $ textToStringBuffer $ Rope.toText rope

131+ pure $ textToStringBuffer . Rope.toText . _text <$> mbVirtual

133− Nothing -> hGetStringBuffer (fromNormalizedFilePath file)

134 case res of

132 case res of

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

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

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

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

@@ -142,7 +140,7 @@ ideTryIOException fp act =

142 <$> try act

140 <$> try act

143

141

144

142

145−getFileContents :: NormalizedFilePath -> Action (FileVersion, StringBuffer)

143+getFileContents :: NormalizedFilePath -> Action (FileVersion, Maybe StringBuffer)

146getFileContents = use_ GetFileContents

144getFileContents = use_ GetFileContents

147

145

148getFileExists :: NormalizedFilePath -> Action Bool

146getFileExists :: NormalizedFilePath -> Action Bool

@@ -180,8 +178,3 @@ setSomethingModified state = do

180 when (isJust setVirtualFileContents) $

178 when (isJust setVirtualFileContents) $

181 fail "setSomethingModified can't be called on this type of VFSHandle"

179 fail "setSomethingModified can't be called on this type of VFSHandle"

182 void $ shakeRun state [] (const $ pure ())

180 void $ shakeRun state [] (const $ pure ())

183−

184−

185−-- would be nice to do this more efficiently...

186−textToStringBuffer :: T.Text -> SB.StringBuffer

187−textToStringBuffer = SB.stringToStringBuffer . T.unpack

src/Development/IDE/Core/Shake.hs+3−3

@@ -400,13 +400,13 @@ updateFileDiagnostics fp k ShakeExtras{diagnostics, state} current = do

400 let newDiags = getFileDiagnostics fp newDiagsStore

401 pure (newDiagsStore, (newDiags, oldDiags))

402 when (newDiags /= oldDiags) $

403− sendEvent $ publishDiagnosticsNotification (fromNormalizedFilePath fp) newDiags

403+ sendEvent $ publishDiagnosticsNotification fp newDiags

404

405−publishDiagnosticsNotification :: FilePath -> [Diagnostic] -> LSP.FromServerMessage

405+publishDiagnosticsNotification :: NormalizedFilePath -> [Diagnostic] -> LSP.FromServerMessage

406publishDiagnosticsNotification fp diags =

407 LSP.NotPublishDiagnostics $

408 LSP.NotificationMessage "2.0" LSP.TextDocumentPublishDiagnostics $

409− LSP.PublishDiagnosticsParams (LSP.filePathToUri fp) (List diags)

409+ LSP.PublishDiagnosticsParams (fromNormalizedUri $ filePathToUri' fp) (List diags)

410

411setPriority :: (Enum a) => a -> Action ()

412setPriority p =

src/Development/IDE/GHC/Compat.hs+11−1

@@ -9,9 +9,12 @@ module Development.IDE.GHC.Compat(

9 HieFile(..),

10 mkHieFile,

11 writeHieFile,

12− readHieFile

12+ readHieFile,

13+ hPutStringBuffer

13 ) where

14 ) where

14

15

16+import StringBuffer

17+

15#ifndef GHC_STABLE

18#ifndef GHC_STABLE

16import HieAst

19import HieAst

17import HieBin

20import HieBin

@@ -22,7 +25,14 @@ import GhcPlugins

22import NameCache

25import NameCache

23import Avail

26import Avail

24import TcRnTypes

27import TcRnTypes

28+import System.IO

29+import Foreign.ForeignPtr

30+

25

31

32+hPutStringBuffer :: Handle -> StringBuffer -> IO ()

33+hPutStringBuffer hdl (StringBuffer buf len cur)

34+ = withForeignPtr (plusForeignPtr buf cur) $ \ptr ->

35+ hPutBuf hdl ptr len

26

36

27mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile

37mkHieFile :: ModSummary -> TcGblEnv -> RenamedSource -> Hsc HieFile

28mkHieFile _ _ _ = return (HieFile () [])

38mkHieFile _ _ _ = return (HieFile () [])

src/Development/IDE/GHC/Error.hs+2−1

@@ -70,7 +70,8 @@ srcSpanToFilename (RealSrcSpan real) = FS.unpackFS $ srcSpanFile real

70

71srcSpanToLocation :: SrcSpan -> Location

72srcSpanToLocation src =

73+ -- important that the URI's we produce have been properly normalized, otherwise they point at weird places in VS Code

73− Location (filePathToUri $ srcSpanToFilename src) (srcSpanToRange src)

74+ Location (fromNormalizedUri $ filePathToUri' $ toNormalizedFilePath $ srcSpanToFilename src) (srcSpanToRange src)

74

75

75-- | Convert a GHC severity to a DAML compiler Severity. Severities below

76-- | Convert a GHC severity to a DAML compiler Severity. Severities below

76-- "Warning" level are dropped (returning Nothing).

77-- "Warning" level are dropped (returning Nothing).

src/Development/IDE/GHC/Util.hs+9−1

@@ -13,7 +13,8 @@ module Development.IDE.GHC.Util(

13 modifyDynFlags,

14 fakeDynFlags,

15 prettyPrint,

16− runGhcEnv

16+ runGhcEnv,

17+ textToStringBuffer

17 ) where

18 ) where

18

19

19import Config

20import Config

@@ -25,6 +26,9 @@ import Data.IORef

25import Control.Exception

26import Control.Exception

26import FileCleanup

27import FileCleanup

27import Platform

28import Platform

29+import qualified Data.Text as T

30+import StringBuffer

31+

28

32

29----------------------------------------------------------------------

33----------------------------------------------------------------------

30-- GHC setup

34-- GHC setup

@@ -47,6 +51,10 @@ lookupPackageConfig unitId env =

47 getPackageConfigMap $ hsc_dflags env

51 getPackageConfigMap $ hsc_dflags env

48

52

49

53

54+-- would be nice to do this more efficiently...

55+textToStringBuffer :: T.Text -> StringBuffer

56+textToStringBuffer = stringToStringBuffer . T.unpack

57+

50

58

51prettyPrint :: Outputable a => a -> String

59prettyPrint :: Outputable a => a -> String

52prettyPrint = showSDoc fakeDynFlags . ppr

60prettyPrint = showSDoc fakeDynFlags . ppr

src/Development/IDE/LSP/LanguageServer.hs+5−3

@@ -114,6 +114,8 @@ data Message

114

115

116modifyOptions :: LSP.Options -> LSP.Options

117−modifyOptions x = x{LSP.textDocumentSync = Just orig{_openClose=Just True, _change=Just TdSyncIncremental}}

117+modifyOptions x = x{LSP.textDocumentSync = Just $ tweak orig}

118+ where

119+ tweak x = x{_openClose=Just True, _change=Just TdSyncIncremental, _save=Just $ SaveOptions Nothing}

118− where orig = fromMaybe tdsDefault $ LSP.textDocumentSync x

120+ orig = fromMaybe tdsDefault $ LSP.textDocumentSync x

119− tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing

121+ tdsDefault = TextDocumentSyncOptions Nothing Nothing Nothing Nothing Nothing

src/Development/IDE/LSP/Notifications.hs+6−1

@@ -43,10 +43,15 @@ setHandlersNotifications = PartialHandlers $ \WithMessage{..} x -> return x

43 setSomethingModified ide

44 logInfo (ideLogger ide) $ "Modified text document: " <> getUri _uri

45

46+ ,LSP.didSaveTextDocumentNotificationHandler = withNotification (LSP.didSaveTextDocumentNotificationHandler x) $

47+ \ide (DidSaveTextDocumentParams TextDocumentIdentifier{_uri}) -> do

48+ setSomethingModified ide

49+ logInfo (ideLogger ide) $ "Saved text document: " <> getUri _uri

50+

46 ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $

51 ,LSP.didCloseTextDocumentNotificationHandler = withNotification (LSP.didCloseTextDocumentNotificationHandler x) $

47 \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do

52 \ide (DidCloseTextDocumentParams TextDocumentIdentifier{_uri}) -> do

48 setSomethingModified ide

53 setSomethingModified ide

49 whenUriFile ide _uri $ \file ->

54 whenUriFile ide _uri $ \file ->

50 modifyFilesOfInterest ide (S.delete file)

55 modifyFilesOfInterest ide (S.delete file)

51 logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri

56 logInfo (ideLogger ide) $ "Closed text document: " <> getUri _uri

52− }

57+ }

src/Development/IDE/Types/Location.hs+13−1

@@ -30,6 +30,7 @@ import Data.Maybe as Maybe

30import Data.Hashable

31import Data.String

32import System.FilePath

33+import System.Info.Extra

33import qualified Language.Haskell.LSP.Types as LSP

34import qualified Language.Haskell.LSP.Types as LSP

34import Language.Haskell.LSP.Types as LSP (

35import Language.Haskell.LSP.Types as LSP (

35 filePathToUri

36 filePathToUri

@@ -55,7 +56,18 @@ toNormalizedFilePath fp = NormalizedFilePath $ normalise' fp

55 -- also normalises things like the case of the drive letter

56 -- also normalises things like the case of the drive letter

56 -- which NormalizedUri does not normalise so we get VFS lookup failures.

57 -- which NormalizedUri does not normalise so we get VFS lookup failures.

57 normalise' :: FilePath -> FilePath

58 normalise' :: FilePath -> FilePath

58− normalise' = map (\c -> if isPathSeparator c then pathSeparator else c)

59+ normalise' = oneSlash . map (\c -> if isPathSeparator c then pathSeparator else c)

60+

61+ -- Allow double slashes as the very first element of the path for UNC drives on Windows

62+ -- otherwise turn adjacent slashes into one. These slashes often arise from dodgy CPP

63+ oneSlash :: FilePath -> FilePath

64+ oneSlash (x:xs) | isWindows = x : f xs

65+ oneSlash xs = f xs

66+

67+ f (x:y:xs) | isPathSeparator x, isPathSeparator y = f (x:xs)

68+ f (x:xs) = x : f xs

69+ f [] = []

70+

59

71

60fromNormalizedFilePath :: NormalizedFilePath -> FilePath

72fromNormalizedFilePath :: NormalizedFilePath -> FilePath

61fromNormalizedFilePath (NormalizedFilePath fp) = fp

73fromNormalizedFilePath (NormalizedFilePath fp) = fp