4f9c756 · ghcide · git.iko.soy

git.iko.soy/ghcide

Parse module headers (#511)

* Create rule to get ModSummary without parsing entire source file * Load file source from disk if not available in memory * Fix build after cherry pick * Couple of fixes - extract getModSummaryFromImports and fix diagnostics - replace GetParsedModule by GetModSummary where possible There is only one usage of GetParsedModule left, and that is in GetSpanInfos for documentation. This the wrong approach, docs should be loaded from interface files and not from sources. TODO * Fix watched file tests Progress notifications are not being sent anymore * Compat with GHC 8.6 * Avoid parsing source files for completions and documentation Instead, embed haddocks in interface files * Allow CPP in module * Force things after parsing in order to release buffers * avoid holding on to stringbuffer unnecessarily * Skip unnecessary file contents read * Drop HscEnv requirement * Add comments on forcing things * Add comments on GHC_LIB restriction * Parse files of interest twice to capture Haddock errors If Opt_Haddock is not enabled we parse twice to capture Haddock parse errors * Parallelize two-pass parsing * Update src/Development/IDE/Core/Compile.hs Co-authored-by: Marcelo Lazaroni <lazaronijunior@gmail.com> Co-authored-by: Moritz Kiefer <moritz.kiefer@purelyfunctional.org>

commit4f9c7561ee26edbc1ecb00c8ee7655d904f8b134 authorPepe Iborra <pepeiborra@gmail.com> dateMon 27 Apr 2020, 10:05 (6 years ago) parent3973238

14 files changed+316−90

compare with master

unifiedsplit

.hlint.yaml+1

@@ -85,6 +85,7 @@

8585 - Development.IDE.Spans.Documentation

8686 - Development.IDE.Spans.Common

8787 - Development.IDE.Plugin.CodeAction

88+ - Development.IDE.Plugin.Completions

8889 - Development.IDE.Plugin.Completions.Logic

8990 - Main

9091

ghcide.cabal+1

@@ -133,6 +133,7 @@ library

133133 Development.IDE.GHC.CPP

134134 Development.IDE.GHC.Orphans

135135 Development.IDE.GHC.Warnings

136+ Development.IDE.GHC.WithDynFlags

136137 Development.IDE.Import.FindImports

137138 Development.IDE.LSP.Notifications

138139 Development.IDE.Spans.AtPoint

src/Development/IDE/Core/Compile.hs+54−9

@@ -19,6 +19,7 @@ module Development.IDE.Core.Compile

1919 , generateByteCode

2020 , generateAndWriteHieFile

2121 , generateAndWriteHiFile

22+ , getModSummaryFromImports

2223 , loadHieFile

2324 , loadInterface

2425 , loadDepModule

@@ -70,16 +71,19 @@ import Control.Exception.Safe

7071import Control.Monad.Extra

7172import Control.Monad.Except

7273import Control.Monad.Trans.Except

74+import Data.Bifunctor (first, second)

7375import qualified Data.Text as T

7476import Data.IORef

7577import Data.List.Extra

7678import Data.Maybe

77−import Data.Tuple.Extra

7879import qualified Data.Map.Strict as Map

7980import System.FilePath

8081import System.Directory

8182import System.IO.Extra

8283import Data.Either.Extra (maybeToEither)

84+import Control.DeepSeq (rnf)

85+import Control.Exception (evaluate)

86+import Exception (ExceptionMonad)

8387

8488

8589-- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.

@@ -250,7 +254,7 @@ hideDiag originalFlags (Reason warning, (nfp, _sh, fd))

250254 | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))

251255hideDiag _originalFlags t = t

252256

253−addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags

257+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags

254258addRelativeImport fp modu dflags = dflags

255259 {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}

256260

@@ -407,16 +411,14 @@ getImportsParsed dflags (L loc parsed) = do

407411 , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"

408412 ])

409413

410−

411414-- | Produce a module summary from a StringBuffer.

412415getModSummaryFromBuffer

413416 :: GhcMonad m

414417 => FilePath

415− -> SB.StringBuffer

416418 -> DynFlags

417419 -> GHC.ParsedSource

418420 -> ExceptT [FileDiagnostic] m ModSummary

419−getModSummaryFromBuffer fp contents dflags parsed = do

421+getModSummaryFromBuffer fp dflags parsed = do

420422 (modName, imports) <- liftEither $ getImportsParsed dflags parsed

421423

422424 modLoc <- liftIO $ mkHomeModLocation dflags modName fp

@@ -432,7 +434,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do

432434 , ms_textual_imps = [imp | (False, imp) <- imports]

433435 , ms_hspp_file = fp

434436 , ms_hspp_opts = dflags

435− , ms_hspp_buf = Just contents

437+ , ms_hspp_buf = Nothing

436438

437439 -- defaults:

438440 , ms_hsc_src = sourceType

@@ -447,8 +449,51 @@ getModSummaryFromBuffer fp contents dflags parsed = do

447449 where

448450 sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile

449451

450−

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

452+-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.

453+-- Runs preprocessors as needed.

454+getModSummaryFromImports

455+ :: (HasDynFlags m, ExceptionMonad m, MonadIO m)

456+ => FilePath

457+ -> Maybe SB.StringBuffer

458+ -> ExceptT [FileDiagnostic] m ModSummary

459+getModSummaryFromImports fp contents = do

460+ (contents, dflags) <- preprocessor fp contents

461+ (srcImports, textualImports, L _ moduleName) <-

462+ ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp

463+

464+ -- Force bits that might keep the string buffer and DynFlags alive unnecessarily

465+ liftIO $ evaluate $ rnf srcImports

466+ liftIO $ evaluate $ rnf textualImports

467+

468+ modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp

469+

470+ let mod = mkModule (thisPackage dflags) moduleName

471+ sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile

472+ summary =

473+ ModSummary

474+ { ms_mod = mod

475+#if MIN_GHC_API_VERSION(8,8,0)

476+ , ms_hie_date = Nothing

477+#endif

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

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

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

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

482+ , ms_hsc_src = sourceType

483+ , ms_hspp_buf = Nothing

484+ , ms_hspp_file = fp

485+ , ms_hspp_opts = dflags

486+ , ms_iface_date = Nothing

487+ , ms_location = modLoc

488+ , ms_obj_date = Nothing

489+ , ms_parsed_mod = Nothing

490+ , ms_srcimps = srcImports

491+ , ms_textual_imps = textualImports

492+ }

493+ return summary

494+

495+

496+-- | Given a buffer, flags, and file path, produce a

452497-- parsed module (or errors) and any parse warnings. Does not run any preprocessors

453498parseFileContents

454499 :: GhcMonad m

@@ -490,7 +535,7 @@ parseFileContents customPreprocessor dflags filename contents = do

490535 let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module

491536 unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs

492537 let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns

493− ms <- getModSummaryFromBuffer filename contents dflags parsed

538+ ms <- getModSummaryFromBuffer filename dflags parsed

494539 let pm =

495540 ParsedModule {

496541 pm_mod_summary = ms

src/Development/IDE/Core/Preprocessor.hs+11−3

@@ -29,11 +29,15 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef)

2929import Data.Text (Text)

3030import qualified Data.Text as T

3131import Outputable (showSDoc)

32+import Control.DeepSeq (NFData(rnf))

33+import Control.Exception (evaluate)

34+import Control.Monad.IO.Class (MonadIO)

35+import Exception (ExceptionMonad)

3236

3337

3438-- | Given a file and some contents, apply any necessary preprocessors,

3539-- e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.

36−preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

40+preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)

3741preprocessor filename mbContents = do

3842 -- Perform unlit

3943 (isOnDisk, contents) <-

@@ -129,13 +133,17 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]

129133

130134-- | This reads the pragma information directly from the provided buffer.

131135parsePragmasIntoDynFlags

132− :: GhcMonad m

136+ :: (ExceptionMonad m, HasDynFlags m, MonadIO m)

133137 => FilePath

134138 -> SB.StringBuffer

135139 -> m (Either [FileDiagnostic] DynFlags)

136140parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do

137− dflags0 <- getSessionDynFlags

141+ dflags0 <- getDynFlags

138142 let opts = Hdr.getOptions dflags0 contents fp

143+

144+ -- Force bits that might keep the dflags and stringBuffer alive unnecessarily

145+ liftIO $ evaluate $ rnf opts

146+

139147 (dflags, _, _) <- parseDynamicFilePragma dflags0 opts

140148 return dflags

141149

src/Development/IDE/Core/RuleTypes.hs+10−1

@@ -105,6 +105,10 @@ type instance RuleResult GetModIface = HiFileResult

105105

106106type instance RuleResult IsFileOfInterest = Bool

107107

108+-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files.

109+-- without needing to parse the entire source

110+type instance RuleResult GetModSummary = ModSummary

111+

108112data GetParsedModule = GetParsedModule

109113 deriving (Eq, Show, Typeable, Generic)

110114instance Hashable GetParsedModule

@@ -177,9 +181,14 @@ instance Hashable GetModIface

177181instance NFData GetModIface

178182instance Binary GetModIface

179183

180−

181184data IsFileOfInterest = IsFileOfInterest

182185 deriving (Eq, Show, Typeable, Generic)

183186instance Hashable IsFileOfInterest

184187instance NFData IsFileOfInterest

185188instance Binary IsFileOfInterest

189+

190+data GetModSummary = GetModSummary

191+ deriving (Eq, Show, Typeable, Generic)

192+instance Hashable GetModSummary

193+instance NFData GetModSummary

194+instance Binary GetModSummary

src/Development/IDE/Core/Rules.hs+95−43

@@ -1,10 +1,12 @@

22-- SPDX-License-Identifier: Apache-2.0

4−{-# LANGUAGE TypeFamilies #-}

5−{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE CPP #-}

5+{-# LANGUAGE TypeFamilies #-}

6+{-# LANGUAGE FlexibleInstances #-}

67{-# LANGUAGE DuplicateRecordFields #-}

78{-# LANGUAGE PatternSynonyms #-}

9+#include "ghc-api-version.h"

810

911-- | A Shake implementation of the compiler service, built

1012-- using the "Shaker" abstraction layer for in-memory use.

@@ -44,6 +46,7 @@ import Development.IDE.Types.Diagnostics

4446import Development.IDE.Types.Location

4547import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)

4648import Development.IDE.GHC.Util

49+import Development.IDE.GHC.WithDynFlags

4750import Data.Coerce

4851import Data.Either.Extra

4952import Data.Maybe

@@ -62,13 +65,16 @@ import Development.IDE.Spans.Type

6265

6366import qualified GHC.LanguageExtensions as LangExt

6467import HscTypes

65−import DynFlags (xopt)

68+import DynFlags (gopt_set, xopt)

6669import GHC.Generics(Generic)

6770

6871import qualified Development.IDE.Spans.AtPoint as AtPoint

6972import Development.IDE.Core.Service

7073import Development.IDE.Core.Shake

7174import Development.Shake.Classes

75+import Control.Monad.Trans.Except (runExceptT)

76+import Data.ByteString (ByteString)

77+import Control.Concurrent.Async (concurrently)

7278

7379-- | This is useful for rules to convert rules that can only produce errors or

7480-- a result into the more general IdeResult type that supports producing

@@ -131,9 +137,9 @@ getHieFile file mod = do

131137

132138getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)

133139getHomeHieFile f = do

134− pm <- use_ GetParsedModule f

140+ ms <- use_ GetModSummary f

135141 let normal_hie_f = toNormalizedFilePath' hie_f

136− hie_f = ml_hie_file $ ms_location $ pm_mod_summary pm

142+ hie_f = ml_hie_file $ ms_location ms

137143 mbHieTimestamp <- use GetModificationTime normal_hie_f

138144 srcTimestamp <- use_ GetModificationTime f

139145

@@ -185,28 +191,51 @@ priorityFilesOfInterest :: Priority

185191priorityFilesOfInterest = Priority (-2)

186192

187193getParsedModuleRule :: Rules ()

188−getParsedModuleRule =

189− defineEarlyCutoff $ \GetParsedModule file -> do

190− (_, contents) <- getFileContents file

191− packageState <- hscEnv <$> use_ GhcSession file

192− opt <- getIdeOptions

193− (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)

194− case res of

195− Nothing -> pure (Nothing, (diag, Nothing))

196− Just (contents, modu) -> do

197− mbFingerprint <- if isNothing $ optShakeFiles opt

198− then pure Nothing

199− else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

200− pure (mbFingerprint, (diag, Just modu))

194+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do

195+ hsc <- hscEnv <$> use_ GhcSession file

196+ opt <- getIdeOptions

197+ (_, contents) <- getFileContents file

198+

199+ let dflags = hsc_dflags hsc

200+ mainParse = getParsedModuleDefinition hsc opt file contents

201+

202+ -- Parse again (if necessary) to capture Haddock parse errors

203+ if gopt Opt_Haddock dflags

204+ then

205+ liftIO mainParse

206+ else do

207+ let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}

208+ haddockParse = do

209+ (_, (!diagsHaddock, _)) <-

210+ getParsedModuleDefinition hscHaddock opt file contents

211+ return diagsHaddock

212+

213+ ((fingerPrint, (diags, res)), diagsHaddock) <-

214+ -- parse twice, with and without Haddocks, concurrently

215+ -- we cannot ignore Haddock parse errors because files of

216+ -- non-interest are always parsed with Haddocks

217+ liftIO $ concurrently mainParse haddockParse

218+

219+ return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))

220+

221+getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))

222+getParsedModuleDefinition packageState opt file contents = do

223+ (diag, res) <- parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)

224+ case res of

225+ Nothing -> pure (Nothing, (diag, Nothing))

226+ Just (contents, modu) -> do

227+ mbFingerprint <- if isNothing $ optShakeFiles opt

228+ then pure Nothing

229+ else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents

230+ pure (mbFingerprint, (diag, Just modu))

201231

202232getLocatedImportsRule :: Rules ()

203233getLocatedImportsRule =

204234 define $ \GetLocatedImports file -> do

205− pm <- use_ GetParsedModule file

206− let ms = pm_mod_summary pm

235+ ms <- use_ GetModSummary file

207236 let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]

208237 env <- hscEnv <$> use_ GhcSession file

209− let dflags = addRelativeImport file pm $ hsc_dflags env

238+ let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env

210239 opt <- getIdeOptions

211240 (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do

212241 diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource

@@ -223,7 +252,6 @@ getLocatedImportsRule =

223252 Nothing -> pure (concat diags, Nothing)

224253 Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))

225254

226−

227255-- | Given a target file path, construct the raw dependency results by following

228256-- imports recursively.

229257rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation

@@ -321,8 +349,8 @@ reportImportCyclesRule =

321349 where loc = srcSpanToLocation (getLoc imp)

322350 fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)

323351 getModuleName file = do

324− pm <- use_ GetParsedModule file

325− pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)

352+ ms <- use_ GetModSummary file

353+ pure (moduleNameString . moduleName . ms_mod $ ms)

326354 showCycle mods = T.intercalate ", " (map T.pack mods)

327355

328356-- returns all transitive dependencies in topological order.

@@ -342,22 +370,31 @@ getSpanInfoRule :: Rules ()

342370getSpanInfoRule =

343371 define $ \GetSpanInfo file -> do

344372 tc <- use_ TypeCheck file

373+ packageState <- hscEnv <$> use_ GhcSession file

345374 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

346375 let tdeps = transitiveModuleDeps deps

376+

377+-- When possible, rely on the haddocks embedded in our interface files

378+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

379+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

380+ let parsedDeps = []

381+#else

347382 parsedDeps <- uses_ GetParsedModule tdeps

383+#endif

384+

348385 ifaces <- uses_ GetModIface tdeps

349386 (fileImports, _) <- use_ GetLocatedImports file

350− packageState <- hscEnv <$> use_ GhcSession file

351387 let imports = second (fmap artifactFilePath) <$> fileImports

352− x <- liftIO $ getSrcSpanInfos packageState imports tc (zip parsedDeps $ map hirModIface ifaces)

388+ x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)

353389 return ([], Just x)

354390

355391-- Typechecks a module.

356392typeCheckRule :: Rules ()

357−typeCheckRule = define $ \TypeCheck file ->

393+typeCheckRule = define $ \TypeCheck file -> do

394+ pm <- use_ GetParsedModule file

358395 -- do not generate interface files as this rule is called

359396 -- for files of interest on every keystroke

360− typeCheckRuleDefinition file SkipGenerationOfInterfaceFiles

397+ typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles

361398

362399data GenerateInterfaceFiles

363400 = DoGenerateInterfaceFiles

@@ -370,10 +407,10 @@ data GenerateInterfaceFiles

370407-- retain the information forever in the shake graph.

371408typeCheckRuleDefinition

372409 :: NormalizedFilePath -- ^ Path to source file

410+ -> ParsedModule

373411 -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?

374412 -> Action (IdeResult TcModuleResult)

375−typeCheckRuleDefinition file generateArtifacts = do

376− pm <- use_ GetParsedModule file

413+typeCheckRuleDefinition file pm generateArtifacts = do

377414 deps <- use_ GetDependencies file

378415 hsc <- hscEnv <$> use_ GhcSession file

379416 -- Figure out whether we need TemplateHaskell or QuasiQuotes support

@@ -454,20 +491,15 @@ loadGhcSession = do

454491

455492getHiFileRule :: Rules ()

456493getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

457− session <- hscEnv <$> use_ GhcSession f

458494 -- get all dependencies interface files, to check for freshness

459495 (deps,_) <- use_ GetLocatedImports f

460496 depHis <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)

461497

462− -- TODO find the hi file without relying on the parsed module

463− -- it should be possible to construct a ModSummary parsing just the imports

464− -- (see HeaderInfo in the GHC package)

465− pm <- use_ GetParsedModule f

466− let hiFile = toNormalizedFilePath' $

467− case ms_hsc_src ms of

498+ ms <- use_ GetModSummary f

499+ let hiFile = toNormalizedFilePath'

500+ $ case ms_hsc_src ms of

468501 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)

469502 _ -> ml_hi_file $ ms_location ms

470− ms = pm_mod_summary pm

471503

472504 IdeOptions{optInterfaceLoadingDiagnostics} <- getIdeOptions

473505

@@ -500,6 +532,7 @@ getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

500532 let d = mkInterfaceFilesGenerationDiag f "Stale interface file"

501533 pure (Nothing, (d, Nothing))

502534 else do

535+ session <- hscEnv <$> use_ GhcSession f

503536 r <- liftIO $ loadInterface session ms deps

504537 case r of

505538 Right iface -> do

@@ -509,6 +542,13 @@ getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do

509542 let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err

510543 return (Nothing, (pure diag, Nothing))

511544

545+getModSummaryRule :: Rules ()

546+getModSummaryRule = define $ \GetModSummary f -> do

547+ dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f

548+ (_, mFileContent) <- getFileContents f

549+ modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $

550+ getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)

551+ return $ either (,Nothing) (([], ) . Just) modS

512552

513553getModIfaceRule :: Rules ()

514554getModIfaceRule = define $ \GetModIface f -> do

@@ -526,11 +566,22 @@ getModIfaceRule = define $ \GetModIface f -> do

526566 tmr <- use TypeCheck f

527567 return ([], extract tmr)

528568 | otherwise -> do

529− -- Otherwise the interface file does not exist or is out of date. Invoke typechecking directly to update it without incurring a dependency on the typecheck rule.

530− (diags, tmr) <- typeCheckRuleDefinition f DoGenerateInterfaceFiles

531− -- Bang pattern is important to avoid leaking 'tmr'

532− let !res = extract tmr

533− return (diags, res)

569+ -- the interface file does not exist or is out of date.

570+ -- Invoke typechecking directly to update it without incurring a dependency

571+ -- on the parsed module and the typecheck rules

572+ hsc <- hscEnv <$> use_ GhcSession f

573+ opt <- getIdeOptions

574+ (_, contents) <- getFileContents f

575+ -- Embed --haddocks in the interface file

576+ hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}

577+ (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f contents

578+ case mb_pm of

579+ Nothing -> return (diags, Nothing)

580+ Just pm -> do

581+ (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles

582+ -- Bang pattern is important to avoid leaking 'tmr'

583+ let !res = extract tmr

584+ return (diags <> diags', res)

534585 where

535586 extract Nothing = Nothing

536587 extract (Just tmr) =

@@ -559,3 +610,4 @@ mainRule = do

559610 getHiFileRule

560611 getModIfaceRule

561612 isFileOfInterestRule

613+ getModSummaryRule

src/Development/IDE/GHC/Compat.hs+26

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

88-- | Attempt at hiding the GHC version differences we can.

99module Development.IDE.GHC.Compat(

10+ getHeaderImports,

1011 HieFileResult(..),

1112 HieFile,

1213 hieExportNames,

@@ -46,7 +47,10 @@ import qualified Module

4647

4748import qualified GHC

4849import GHC hiding (ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation)

50+import qualified HeaderInfo as Hdr

4951import Avail

52+import ErrUtils (ErrorMessages)

53+import FastString (FastString)

5054

5155#if MIN_GHC_API_VERSION(8,8,0)

5256import Control.Applicative ((<|>))

@@ -69,6 +73,7 @@ import IfaceEnv

6973#endif

7074

7175import Binary

76+import Control.Exception (catch)

7277import Data.ByteString (ByteString)

7378import GhcPlugins hiding (ModLocation)

7479import NameCache

@@ -250,3 +255,24 @@ readHieFile _ _ = return undefined

250255#endif

251256

252257#endif

258+

259+getHeaderImports

260+ :: DynFlags

261+ -> StringBuffer

262+ -> FilePath

263+ -> FilePath

264+ -> IO

265+ ( Either

266+ ErrorMessages

267+ ( [(Maybe FastString, Located ModuleName)]

268+ , [(Maybe FastString, Located ModuleName)]

269+ , Located ModuleName

270+ )

271+ )

272+#if MIN_GHC_API_VERSION(8,8,0)

273+getHeaderImports = Hdr.getImports

274+#else

275+getHeaderImports a b c d =

276+ catch (Right <$> Hdr.getImports a b c d)

277+ (return . Left . srcErrorMessages)

278+#endif

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

@@ -9,6 +9,7 @@ module Development.IDE.GHC.Error

99 , diagFromStrings

1010 , diagFromGhcException

1111 , catchSrcErrors

12+ , mergeDiagnostics

1213

1314 -- * utilities working with spans

1415 , srcSpanToLocation

@@ -36,6 +37,7 @@ import Panic

3637import ErrUtils

3738import SrcLoc

3839import qualified Outputable as Out

40+import Exception (ExceptionMonad)

3941

4042

4143

@@ -61,6 +63,25 @@ diagFromErrMsg diagSource dflags e =

6163diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]

6264diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList

6365

66+-- | Merges two sorted lists of diagnostics, removing duplicates.

67+-- Assumes all the diagnostics are for the same file.

68+mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]

69+mergeDiagnostics aa [] = aa

70+mergeDiagnostics [] bb = bb

71+mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb)

72+ | ar < br

73+ = a : mergeDiagnostics aa (b:bb)

74+ | br < ar

75+ = b : mergeDiagnostics (a:aa) bb

76+ | _severity ad == _severity bd

77+ && _source ad == _source bd

78+ && _message ad == _message bd

79+ && _code ad == _code bd

80+ && _relatedInformation ad == _relatedInformation bd

81+ && _tags ad == _tags bd

82+ = a : mergeDiagnostics aa bb

83+ | otherwise

84+ = a : b : mergeDiagnostics aa bb

6485

6586-- | Convert a GHC SrcSpan to a DAML compiler Range

6687srcSpanToRange :: SrcSpan -> Range

@@ -128,7 +149,7 @@ realSpan = \case

128149

129150-- | Run something in a Ghc monad and catch the errors (SourceErrors and

130151-- compiler-internal exceptions like Panic or InstallationError).

131−catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)

152+catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)

132153catchSrcErrors fromWhere ghcM = do

133154 dflags <- getDynFlags

134155 handleGhcException (ghcExceptionToDiagnostics dflags) $

src/Development/IDE/GHC/Orphans.hs+6−3

@@ -31,7 +31,7 @@ instance NFData Linkable where rnf = rwhnf

3131instance Show InstalledUnitId where

3232 show = installedUnitIdString

3333

34−instance NFData InstalledUnitId where rnf = rwhnf

34+instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS

3535

3636instance NFData SB.StringBuffer where rnf = rwhnf

3737

@@ -40,8 +40,8 @@ instance Show Module where

4040

4141instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint

4242

43−instance NFData (GenLocated SrcSpan ModuleName) where

44− rnf = rwhnf

43+instance (NFData l, NFData e) => NFData (GenLocated l e) where

44+ rnf (L l e) = rnf l `seq` rnf e

4545

4646instance Show ModSummary where

4747 show = show . ms_mod

@@ -52,6 +52,9 @@ instance Show ParsedModule where

5252instance NFData ModSummary where

5353 rnf = rwhnf

5454

55+instance NFData FastString where

56+ rnf = rwhnf

57+

5558instance NFData ParsedModule where

5659 rnf = rwhnf

5760

src/Development/IDE/GHC/Util.hs+3−5

@@ -147,22 +147,20 @@ runGhcEnv env act = do

147147-- | Given a module location, and its parse tree, figure out what is the include directory implied by it.

148148-- For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory

149149-- @\/usr\/Test@ should be on the include path to find sibling modules.

150−moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath

150+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath

151151-- The call to takeDirectory is required since DAML does not require that

152152-- the file name matches the module name in the last component.

153153-- Once that has changed we can get rid of this.

154−moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm

154+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn

155155 -- This happens for single-component modules since takeDirectory "A" == "."

156156 | modDir == "." = Just pathDir

157157 | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir

158158 where

159− ms = GHC.pm_mod_summary pm

160− mod' = GHC.ms_mod ms

161159 -- A for module A.B

162160 modDir =

163161 takeDirectory $

164162 fromNormalizedFilePath $ toNormalizedFilePath' $

165− moduleNameSlashes $ GHC.moduleName mod'

163+ moduleNameSlashes mn

166164

167165-- | An 'HscEnv' with equality. Two values are considered equal

168166-- if they are created with the same call to 'newHscEnvEq'.

src/Development/IDE/GHC/WithDynFlags.hsnew file+30

@@ -0,0 +1,30 @@

1+module Development.IDE.GHC.WithDynFlags

2+( WithDynFlags

3+, evalWithDynFlags

4+) where

6+import Control.Monad.Trans.Reader (ask, ReaderT(..))

7+import GHC (DynFlags)

8+import Control.Monad.IO.Class (MonadIO)

9+import Exception (ExceptionMonad(..))

10+import Control.Monad.Trans.Class (MonadTrans(..))

11+import GhcPlugins (HasDynFlags(..))

12+

13+-- | A monad transformer implementing the 'HasDynFlags' effect

14+newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}

15+ deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)

16+

17+evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a

18+evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags

19+

20+instance Monad m => HasDynFlags (WithDynFlags m) where

21+ getDynFlags = WithDynFlags ask

22+

23+instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where

24+ gmask f = WithDynFlags $ ReaderT $ \env ->

25+ gmask $ \restore ->

26+ let restore' = lift . restore . flip runReaderT env . withDynFlags

27+ in runReaderT (withDynFlags $ f restore') env

28+

29+ gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->

30+ gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)

src/Development/IDE/Plugin/Completions.hs+13−2

@@ -1,9 +1,10 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE TypeFamilies #-}

3+#include "ghc-api-version.h"

35module Development.IDE.Plugin.Completions(plugin) where

57import Control.Applicative

6−import Data.Maybe

78import Language.Haskell.LSP.Messages

89import Language.Haskell.LSP.Types

910import qualified Language.Haskell.LSP.Core as LSP

@@ -22,8 +23,11 @@ import Development.IDE.Core.RuleTypes

2223import Development.IDE.Core.Shake

2324import Development.IDE.GHC.Util

2425import Development.IDE.LSP.Server

25−import Development.IDE.Import.DependencyInformation

2626

27+#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)

28+import Data.Maybe

29+import Development.IDE.Import.DependencyInformation

30+#endif

2731

2832plugin :: Plugin c

2933plugin = Plugin produceCompletions setHandlersCompletion

@@ -31,8 +35,15 @@ plugin = Plugin produceCompletions setHandlersCompletion

3135produceCompletions :: Rules ()

3236produceCompletions =

3337 define $ \ProduceCompletions file -> do

38+

39+-- When possible, rely on the haddocks embedded in our interface files

40+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'

41+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)

42+ let parsedDeps = []

43+#else

3444 deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file

3545 parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)

46+#endif

3647 tm <- fmap fst <$> useWithStale TypeCheck file

3748 packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file

3849 case (tm, packageState) of

src/Development/IDE/Spans/Calculate.hs+9−7

@@ -52,29 +52,31 @@ getSrcSpanInfos

5252 :: HscEnv

5353 -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order

5454 -> TcModuleResult

55− -> [(ParsedModule, ModIface)]

55+ -> [ParsedModule] -- ^ Dependencies parsed, optional

56+ -> [ModIface] -- ^ Dependencies module interfaces, required

5657 -> IO SpansInfo

57−getSrcSpanInfos env imports tc deps =

58+getSrcSpanInfos env imports tc parsedDeps deps =

5859 evalGhcEnv env $

59− getSpanInfo imports (tmrModule tc) deps

60+ getSpanInfo imports (tmrModule tc) parsedDeps deps

6061

6162-- | Get ALL source spans in the module.

6263getSpanInfo :: GhcMonad m

6364 => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports

6465 -> TypecheckedModule

65− -> [(ParsedModule, ModIface)]

66+ -> [ParsedModule]

67+ -> [ModIface]

6668 -> m SpansInfo

67−getSpanInfo mods tcm@TypecheckedModule{..} deps =

69+getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =

6870 do let tcs = tm_typechecked_source

6971 bs = listifyAllSpans tcs :: [LHsBind GhcTc]

7072 es = listifyAllSpans tcs :: [LHsExpr GhcTc]

7173 ps = listifyAllSpans' tcs :: [Pat GhcTc]

7274 ts = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]

73− allModules = tm_parsed_module : map fst deps

75+ allModules = tm_parsed_module : parsedDeps

7476 funBinds = funBindMap tm_parsed_module

7577

7678 -- Load all modules in HPT to make their interface documentation available

77− mapM_ ((`loadDepModule` Nothing) . snd) (reverse deps)

79+ mapM_ (`loadDepModule` Nothing) (reverse deps)

7880 forM_ (modInfoIface tm_checked_module_info) $ \modIface ->

7981 modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)

8082

test/exe/Main.hs+35−16

@@ -1,6 +1,7 @@

22-- SPDX-License-Identifier: Apache-2.0

4+{-# LANGUAGE AllowAmbiguousTypes #-}

45{-# LANGUAGE DuplicateRecordFields #-}

56{-# LANGUAGE PatternSynonyms #-}

67{-# LANGUAGE CPP #-}

@@ -12,7 +13,7 @@ import Control.Applicative.Combinators

1213import Control.Exception (catch)

1314import Control.Monad

1415import Control.Monad.IO.Class (liftIO)

15−import Data.Aeson (Value)

16+import Data.Aeson (FromJSON, Value)

1617import Data.Char (toLower)

1718import Data.Foldable

1819import Data.List

@@ -21,6 +22,7 @@ import qualified Data.Rope.UTF16 as Rope

2122import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)

2223import Development.IDE.GHC.Util

2324import qualified Data.Text as T

25+import Data.Typeable

2426import Development.IDE.Spans.Common

2527import Development.IDE.Test

2628import Development.IDE.Test.Runfiles

@@ -410,6 +412,19 @@ diagnosticTests = testGroup "diagnostics"

410412 liftIO $ unless ("redundant" `T.isInfixOf` msg) $

411413 assertFailure ("Expected redundant import but got " <> T.unpack msg)

412414 closeDoc a

415+ , testSessionWait "haddock parse error" $ do

416+ let fooContent = T.unlines

417+ [ "module Foo where"

418+ , "foo :: Int"

419+ , "foo = 1 {-|-}"

420+ ]

421+ _ <- openDoc' "Foo.hs" "haskell" fooContent

422+ expectDiagnostics

423+ [ ( "Foo.hs"

424+ , [(DsError, (2, 8), "Parse error on input")

425+ ]

426+ )

427+ ]

413428 ]

414429

415430codeActionTests :: TestTree

@@ -436,24 +451,28 @@ watchedFilesTests :: TestTree

436451watchedFilesTests = testGroup "watched files"

437452 [ testSession' "workspace files" $ \sessionDir -> do

438453 liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"

439− _ <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport B"

440− watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd

454+ _doc <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"

455+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

441456

442457 -- Expect 6 subscriptions (A does not get any because it's VFS):

443− -- - /path-to-workspace/B.hs

444− -- - /path-to-workspace/B.lhs

445− -- - B.hs

446− -- - B.lhs

447− -- - src/B.hs

448− -- - src/B.lhs

458+ -- - /path-to-workspace/WatchedFilesMissingModule.hs

459+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs

460+ -- - WatchedFilesMissingModule.hs

461+ -- - WatchedFilesMissingModule.lhs

462+ -- - src/WatchedFilesMissingModule.hs

463+ -- - src/WatchedFilesMissingModule.lhs

449464 liftIO $ length watchedFileRegs @?= 6

450465

451466 , testSession' "non workspace file" $ \sessionDir -> do

452467 liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"

453− _ <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport B"

454− watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd

455−

456− -- Expect 4 subscriptions:

468+ _doc <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"

469+ watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification

470+

471+ -- Expect 4 subscriptions (/tmp does not get any as it is out of the workspace):

472+ -- - /path-to-workspace/WatchedFilesMissingModule.hs

473+ -- - /path-to-workspace/WatchedFilesMissingModule.lhs

474+ -- - WatchedFilesMissingModule.hs

475+ -- - WatchedFilesMissingModule.lhs

457476 liftIO $ length watchedFileRegs @?= 4

458477

459478 -- TODO add a test for didChangeWorkspaceFolder

@@ -2323,9 +2342,9 @@ nthLine i r

23232342 | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)

23242343 | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r

23252344

2326−getWatchedFilesSubscriptionsUntilProgressEnd :: Session [Maybe Value]

2327−getWatchedFilesSubscriptionsUntilProgressEnd = do

2328− msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)

2345+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]

2346+getWatchedFilesSubscriptionsUntil = do

2347+ msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)

23292348 return

23302349 [ args

23312350 | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs