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>

.hlint.yaml

@@ -85,6 +85,7 @@
     - Development.IDE.Spans.Documentation
     - Development.IDE.Spans.Common
     - Development.IDE.Plugin.CodeAction
+    - Development.IDE.Plugin.Completions
     - Development.IDE.Plugin.Completions.Logic
     - Main
 

ghcide.cabal

@@ -133,6 +133,7 @@ library
         Development.IDE.GHC.CPP
         Development.IDE.GHC.Orphans
         Development.IDE.GHC.Warnings
+        Development.IDE.GHC.WithDynFlags
         Development.IDE.Import.FindImports
         Development.IDE.LSP.Notifications
         Development.IDE.Spans.AtPoint

src/Development/IDE/Core/Compile.hs

@@ -19,6 +19,7 @@ module Development.IDE.Core.Compile
   , generateByteCode
   , generateAndWriteHieFile
   , generateAndWriteHiFile
+  , getModSummaryFromImports
   , loadHieFile
   , loadInterface
   , loadDepModule
@@ -70,16 +71,19 @@ import Control.Exception.Safe
 import Control.Monad.Extra
 import Control.Monad.Except
 import Control.Monad.Trans.Except
+import Data.Bifunctor                           (first, second)
 import qualified Data.Text as T
 import           Data.IORef
 import           Data.List.Extra
 import           Data.Maybe
-import           Data.Tuple.Extra
 import qualified Data.Map.Strict                          as Map
 import           System.FilePath
 import           System.Directory
 import           System.IO.Extra
 import Data.Either.Extra (maybeToEither)
+import Control.DeepSeq (rnf)
+import Control.Exception (evaluate)
+import Exception (ExceptionMonad)
 
 
 -- | Given a string buffer, return the string (after preprocessing) and the 'ParsedModule'.
@@ -250,7 +254,7 @@ hideDiag originalFlags (Reason warning, (nfp, _sh, fd))
   | not (wopt warning originalFlags) = (Reason warning, (nfp, HideDiag, fd))
 hideDiag _originalFlags t = t
 
-addRelativeImport :: NormalizedFilePath -> ParsedModule -> DynFlags -> DynFlags
+addRelativeImport :: NormalizedFilePath -> ModuleName -> DynFlags -> DynFlags
 addRelativeImport fp modu dflags = dflags
     {importPaths = nubOrd $ maybeToList (moduleImportPath fp modu) ++ importPaths dflags}
 
@@ -407,16 +411,14 @@ getImportsParsed dflags (L loc parsed) = do
     , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
     ])
 
-
 -- | Produce a module summary from a StringBuffer.
 getModSummaryFromBuffer
     :: GhcMonad m
     => FilePath
-    -> SB.StringBuffer
     -> DynFlags
     -> GHC.ParsedSource
     -> ExceptT [FileDiagnostic] m ModSummary
-getModSummaryFromBuffer fp contents dflags parsed = do
+getModSummaryFromBuffer fp dflags parsed = do
   (modName, imports) <- liftEither $ getImportsParsed dflags parsed
 
   modLoc <- liftIO $ mkHomeModLocation dflags modName fp
@@ -432,7 +434,7 @@ getModSummaryFromBuffer fp contents dflags parsed = do
     , ms_textual_imps = [imp | (False, imp) <- imports]
     , ms_hspp_file    = fp
     , ms_hspp_opts    = dflags
-    , ms_hspp_buf     = Just contents
+    , ms_hspp_buf     = Nothing
 
     -- defaults:
     , ms_hsc_src      = sourceType
@@ -447,8 +449,51 @@ getModSummaryFromBuffer fp contents dflags parsed = do
     where
       sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
 
+-- | Given a buffer, env and filepath, produce a module summary by parsing only the imports.
+--   Runs preprocessors as needed.
+getModSummaryFromImports
+  :: (HasDynFlags m, ExceptionMonad m, MonadIO m)
+  => FilePath
+  -> Maybe SB.StringBuffer
+  -> ExceptT [FileDiagnostic] m ModSummary
+getModSummaryFromImports fp contents = do
+    (contents, dflags) <- preprocessor fp contents
+    (srcImports, textualImports, L _ moduleName) <-
+        ExceptT $ liftIO $ first (diagFromErrMsgs "parser" dflags) <$> GHC.getHeaderImports dflags contents fp fp
 
--- | Given a buffer, flags, file path and module summary, produce a
+    -- Force bits that might keep the string buffer and DynFlags alive unnecessarily
+    liftIO $ evaluate $ rnf srcImports
+    liftIO $ evaluate $ rnf textualImports
+
+    modLoc <- liftIO $ mkHomeModLocation dflags moduleName fp
+
+    let mod = mkModule (thisPackage dflags) moduleName
+        sourceType = if "-boot" `isSuffixOf` takeExtension fp then HsBootFile else HsSrcFile
+        summary =
+            ModSummary
+                { ms_mod          = mod
+#if MIN_GHC_API_VERSION(8,8,0)
+                , ms_hie_date     = Nothing
+#endif
+                , ms_hs_date      = error "Rules should not depend on ms_hs_date"
+        -- When we are working with a virtual file we do not have a file date.
+        -- To avoid silent issues where something is not processed because the date
+        -- has not changed, we make sure that things blow up if they depend on the date.
+                , ms_hsc_src      = sourceType
+                , ms_hspp_buf     = Nothing
+                , ms_hspp_file    = fp
+                , ms_hspp_opts    = dflags
+                , ms_iface_date   = Nothing
+                , ms_location     = modLoc
+                , ms_obj_date     = Nothing
+                , ms_parsed_mod   = Nothing
+                , ms_srcimps      = srcImports
+                , ms_textual_imps = textualImports
+                }
+    return summary
+
+
+-- | Given a buffer, flags, and file path, produce a
 -- parsed module (or errors) and any parse warnings. Does not run any preprocessors
 parseFileContents
        :: GhcMonad m
@@ -490,7 +535,7 @@ parseFileContents customPreprocessor dflags filename contents = do
                let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
                unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
                let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
-               ms <- getModSummaryFromBuffer filename contents dflags parsed
+               ms <- getModSummaryFromBuffer filename dflags parsed
                let pm =
                      ParsedModule {
                          pm_mod_summary = ms

src/Development/IDE/Core/Preprocessor.hs

@@ -29,11 +29,15 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Outputable (showSDoc)
+import Control.DeepSeq (NFData(rnf))
+import Control.Exception (evaluate)
+import Control.Monad.IO.Class (MonadIO)
+import Exception (ExceptionMonad)
 
 
 -- | Given a file and some contents, apply any necessary preprocessors,
 --   e.g. unlit/cpp. Return the resulting buffer and the DynFlags it implies.
-preprocessor :: GhcMonad m => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
+preprocessor :: (ExceptionMonad m, HasDynFlags m, MonadIO m) => FilePath -> Maybe StringBuffer -> ExceptT [FileDiagnostic] m (StringBuffer, DynFlags)
 preprocessor filename mbContents = do
     -- Perform unlit
     (isOnDisk, contents) <-
@@ -129,13 +133,17 @@ isLiterate x = takeExtension x `elem` [".lhs",".lhs-boot"]
 
 -- | This reads the pragma information directly from the provided buffer.
 parsePragmasIntoDynFlags
-    :: GhcMonad m
+    :: (ExceptionMonad m, HasDynFlags m, MonadIO m)
     => FilePath
     -> SB.StringBuffer
     -> m (Either [FileDiagnostic] DynFlags)
 parsePragmasIntoDynFlags fp contents = catchSrcErrors "pragmas" $ do
-    dflags0  <- getSessionDynFlags
+    dflags0  <- getDynFlags
     let opts = Hdr.getOptions dflags0 contents fp
+
+    -- Force bits that might keep the dflags and stringBuffer alive unnecessarily
+    liftIO $ evaluate $ rnf opts
+
     (dflags, _, _) <- parseDynamicFilePragma dflags0 opts
     return dflags
 

src/Development/IDE/Core/RuleTypes.hs

@@ -105,6 +105,10 @@ type instance RuleResult GetModIface = HiFileResult
 
 type instance RuleResult IsFileOfInterest = Bool
 
+-- | Generate a ModSummary that has enough information to be used to get .hi and .hie files.
+-- without needing to parse the entire source
+type instance RuleResult GetModSummary = ModSummary
+
 data GetParsedModule = GetParsedModule
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable GetParsedModule
@@ -177,9 +181,14 @@ instance Hashable GetModIface
 instance NFData   GetModIface
 instance Binary   GetModIface
 
-
 data IsFileOfInterest = IsFileOfInterest
     deriving (Eq, Show, Typeable, Generic)
 instance Hashable IsFileOfInterest
 instance NFData   IsFileOfInterest
 instance Binary   IsFileOfInterest
+
+data GetModSummary = GetModSummary
+    deriving (Eq, Show, Typeable, Generic)
+instance Hashable GetModSummary
+instance NFData   GetModSummary
+instance Binary   GetModSummary

src/Development/IDE/Core/Rules.hs

@@ -1,10 +1,12 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE PatternSynonyms       #-}
+#include "ghc-api-version.h"
 
 -- | A Shake implementation of the compiler service, built
 --   using the "Shaker" abstraction layer for in-memory use.
@@ -44,6 +46,7 @@ import           Development.IDE.Types.Diagnostics
 import Development.IDE.Types.Location
 import Development.IDE.GHC.Compat hiding (parseModule, typecheckModule)
 import Development.IDE.GHC.Util
+import Development.IDE.GHC.WithDynFlags
 import Data.Coerce
 import Data.Either.Extra
 import Data.Maybe
@@ -62,13 +65,16 @@ import Development.IDE.Spans.Type
 
 import qualified GHC.LanguageExtensions as LangExt
 import HscTypes
-import DynFlags (xopt)
+import DynFlags (gopt_set, xopt)
 import GHC.Generics(Generic)
 
 import qualified Development.IDE.Spans.AtPoint as AtPoint
 import Development.IDE.Core.Service
 import Development.IDE.Core.Shake
 import Development.Shake.Classes
+import Control.Monad.Trans.Except (runExceptT)
+import Data.ByteString (ByteString)
+import Control.Concurrent.Async (concurrently)
 
 -- | This is useful for rules to convert rules that can only produce errors or
 -- a result into the more general IdeResult type that supports producing
@@ -131,9 +137,9 @@ getHieFile file mod = do
 
 getHomeHieFile :: NormalizedFilePath -> Action ([a], Maybe HieFile)
 getHomeHieFile f = do
-  pm <- use_ GetParsedModule f
+  ms <- use_ GetModSummary f
   let normal_hie_f = toNormalizedFilePath' hie_f
-      hie_f = ml_hie_file $ ms_location $ pm_mod_summary pm
+      hie_f = ml_hie_file $ ms_location ms
   mbHieTimestamp <- use GetModificationTime normal_hie_f
   srcTimestamp   <- use_ GetModificationTime f
 
@@ -185,28 +191,51 @@ priorityFilesOfInterest :: Priority
 priorityFilesOfInterest = Priority (-2)
 
 getParsedModuleRule :: Rules ()
-getParsedModuleRule =
-    defineEarlyCutoff $ \GetParsedModule file -> do
-        (_, contents) <- getFileContents file
-        packageState <- hscEnv <$> use_ GhcSession file
-        opt <- getIdeOptions
-        (diag, res) <- liftIO $ parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
-        case res of
-            Nothing -> pure (Nothing, (diag, Nothing))
-            Just (contents, modu) -> do
-                mbFingerprint <- if isNothing $ optShakeFiles opt
-                    then pure Nothing
-                    else liftIO $ Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
-                pure (mbFingerprint, (diag, Just modu))
+getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
+    hsc <- hscEnv <$> use_ GhcSession file
+    opt <- getIdeOptions
+    (_, contents) <- getFileContents file
+
+    let dflags    = hsc_dflags hsc
+        mainParse = getParsedModuleDefinition hsc opt file contents
+
+    -- Parse again (if necessary) to capture Haddock parse errors
+    if gopt Opt_Haddock dflags
+        then
+            liftIO mainParse
+        else do
+            let hscHaddock = hsc{hsc_dflags = gopt_set dflags Opt_Haddock}
+                haddockParse = do
+                    (_, (!diagsHaddock, _)) <-
+                        getParsedModuleDefinition hscHaddock opt file contents
+                    return diagsHaddock
+
+            ((fingerPrint, (diags, res)), diagsHaddock) <-
+                -- parse twice, with and without Haddocks, concurrently
+                -- we cannot ignore Haddock parse errors because files of
+                -- non-interest are always parsed with Haddocks
+                liftIO $ concurrently mainParse haddockParse
+
+            return (fingerPrint, (mergeDiagnostics diags diagsHaddock, res))
+
+getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
+getParsedModuleDefinition packageState opt file contents = do
+    (diag, res) <- parseModule opt packageState (fromNormalizedFilePath file) (fmap textToStringBuffer contents)
+    case res of
+        Nothing -> pure (Nothing, (diag, Nothing))
+        Just (contents, modu) -> do
+            mbFingerprint <- if isNothing $ optShakeFiles opt
+                then pure Nothing
+                else Just . fingerprintToBS <$> fingerprintFromStringBuffer contents
+            pure (mbFingerprint, (diag, Just modu))
 
 getLocatedImportsRule :: Rules ()
 getLocatedImportsRule =
     define $ \GetLocatedImports file -> do
-        pm <- use_ GetParsedModule file
-        let ms = pm_mod_summary pm
+        ms <- use_ GetModSummary file
         let imports = [(False, imp) | imp <- ms_textual_imps ms] ++ [(True, imp) | imp <- ms_srcimps ms]
         env <- hscEnv <$> use_ GhcSession file
-        let dflags = addRelativeImport file pm $ hsc_dflags env
+        let dflags = addRelativeImport file (moduleName $ ms_mod ms) $ hsc_dflags env
         opt <- getIdeOptions
         (diags, imports') <- fmap unzip $ forM imports $ \(isSource, (mbPkgName, modName)) -> do
             diagOrImp <- locateModule dflags (optExtensions opt) getFileExists modName mbPkgName isSource
@@ -223,7 +252,6 @@ getLocatedImportsRule =
             Nothing -> pure (concat diags, Nothing)
             Just pkgImports -> pure (concat diags, Just (moduleImports, Set.fromList $ concat pkgImports))
 
-
 -- | Given a target file path, construct the raw dependency results by following
 -- imports recursively.
 rawDependencyInformation :: NormalizedFilePath -> Action RawDependencyInformation
@@ -321,8 +349,8 @@ reportImportCyclesRule =
             where loc = srcSpanToLocation (getLoc imp)
                   fp = toNormalizedFilePath' $ srcSpanToFilename (getLoc imp)
           getModuleName file = do
-           pm <- use_ GetParsedModule file
-           pure (moduleNameString . moduleName . ms_mod $ pm_mod_summary pm)
+           ms <- use_ GetModSummary file
+           pure (moduleNameString . moduleName . ms_mod $ ms)
           showCycle mods  = T.intercalate ", " (map T.pack mods)
 
 -- returns all transitive dependencies in topological order.
@@ -342,22 +370,31 @@ getSpanInfoRule :: Rules ()
 getSpanInfoRule =
     define $ \GetSpanInfo file -> do
         tc <- use_ TypeCheck file
+        packageState <- hscEnv <$> use_ GhcSession file
         deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
         let tdeps = transitiveModuleDeps deps
+
+-- When possible, rely on the haddocks embedded in our interface files
+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
+        let parsedDeps = []
+#else
         parsedDeps <- uses_ GetParsedModule tdeps
+#endif
+
         ifaces <- uses_ GetModIface tdeps
         (fileImports, _) <- use_ GetLocatedImports file
-        packageState <- hscEnv <$> use_ GhcSession file
         let imports = second (fmap artifactFilePath) <$> fileImports
-        x <- liftIO $ getSrcSpanInfos packageState imports tc (zip parsedDeps $ map hirModIface ifaces)
+        x <- liftIO $ getSrcSpanInfos packageState imports tc parsedDeps (map hirModIface ifaces)
         return ([], Just x)
 
 -- Typechecks a module.
 typeCheckRule :: Rules ()
-typeCheckRule = define $ \TypeCheck file ->
+typeCheckRule = define $ \TypeCheck file -> do
+    pm <- use_ GetParsedModule file
     -- do not generate interface files as this rule is called
     -- for files of interest on every keystroke
-    typeCheckRuleDefinition file SkipGenerationOfInterfaceFiles
+    typeCheckRuleDefinition file pm SkipGenerationOfInterfaceFiles
 
 data GenerateInterfaceFiles
     = DoGenerateInterfaceFiles
@@ -370,10 +407,10 @@ data GenerateInterfaceFiles
 -- retain the information forever in the shake graph.
 typeCheckRuleDefinition
     :: NormalizedFilePath     -- ^ Path to source file
+    -> ParsedModule
     -> GenerateInterfaceFiles -- ^ Should generate .hi and .hie files ?
     -> Action (IdeResult TcModuleResult)
-typeCheckRuleDefinition file generateArtifacts = do
-  pm   <- use_ GetParsedModule file
+typeCheckRuleDefinition file pm generateArtifacts = do
   deps <- use_ GetDependencies file
   hsc  <- hscEnv <$> use_ GhcSession file
   -- Figure out whether we need TemplateHaskell or QuasiQuotes support
@@ -454,20 +491,15 @@ loadGhcSession = do
 
 getHiFileRule :: Rules ()
 getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do
-  session <- hscEnv <$> use_ GhcSession f
   -- get all dependencies interface files, to check for freshness
   (deps,_) <- use_ GetLocatedImports f
   depHis  <- traverse (use GetHiFile) (mapMaybe (fmap artifactFilePath . snd) deps)
 
-  -- TODO find the hi file without relying on the parsed module
-  --      it should be possible to construct a ModSummary parsing just the imports
-  --      (see HeaderInfo in the GHC package)
-  pm      <- use_ GetParsedModule f
-  let hiFile = toNormalizedFilePath' $
-            case ms_hsc_src ms of
+  ms <- use_ GetModSummary f
+  let hiFile = toNormalizedFilePath'
+             $ case ms_hsc_src ms of
                 HsBootFile -> addBootSuffix (ml_hi_file $ ms_location ms)
                 _ -> ml_hi_file $ ms_location ms
-      ms     = pm_mod_summary pm
 
   IdeOptions{optInterfaceLoadingDiagnostics} <- getIdeOptions
 
@@ -500,6 +532,7 @@ getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do
               let d = mkInterfaceFilesGenerationDiag f "Stale interface file"
               pure (Nothing, (d, Nothing))
             else do
+              session <- hscEnv <$> use_ GhcSession f
               r <- liftIO $ loadInterface session ms deps
               case r of
                 Right iface -> do
@@ -509,6 +542,13 @@ getHiFileRule = defineEarlyCutoff $ \GetHiFile f -> do
                   let diag = ideErrorWithSource (Just "interface file loading") (Just DsError) f . T.pack $ err
                   return (Nothing, (pure diag, Nothing))
 
+getModSummaryRule :: Rules ()
+getModSummaryRule = define $ \GetModSummary f -> do
+    dflags <- hsc_dflags . hscEnv <$> use_ GhcSession f
+    (_, mFileContent) <- getFileContents f
+    modS <- liftIO $ evalWithDynFlags dflags $ runExceptT $
+        getModSummaryFromImports (fromNormalizedFilePath f) (textToStringBuffer <$> mFileContent)
+    return $ either (,Nothing) (([], ) . Just) modS
 
 getModIfaceRule :: Rules ()
 getModIfaceRule = define $ \GetModIface f -> do
@@ -526,11 +566,22 @@ getModIfaceRule = define $ \GetModIface f -> do
             tmr <- use TypeCheck f
             return ([], extract tmr)
           | otherwise -> do
-            -- 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.
-            (diags, tmr) <- typeCheckRuleDefinition f DoGenerateInterfaceFiles
-            -- Bang pattern is important to avoid leaking 'tmr'
-            let !res = extract tmr
-            return (diags, res)
+            -- the interface file does not exist or is out of date.
+            -- Invoke typechecking directly to update it without incurring a dependency
+            -- on the parsed module and the typecheck rules
+            hsc <- hscEnv <$> use_ GhcSession f
+            opt <- getIdeOptions
+            (_, contents) <- getFileContents f
+            -- Embed --haddocks in the interface file
+            hsc <- pure hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}
+            (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f contents
+            case mb_pm of
+                Nothing -> return (diags, Nothing)
+                Just pm -> do
+                    (diags', tmr) <- typeCheckRuleDefinition f pm DoGenerateInterfaceFiles
+                    -- Bang pattern is important to avoid leaking 'tmr'
+                    let !res = extract tmr
+                    return (diags <> diags', res)
     where
       extract Nothing = Nothing
       extract (Just tmr) =
@@ -559,3 +610,4 @@ mainRule = do
     getHiFileRule
     getModIfaceRule
     isFileOfInterestRule
+    getModSummaryRule

src/Development/IDE/GHC/Compat.hs

@@ -7,6 +7,7 @@
 
 -- | Attempt at hiding the GHC version differences we can.
 module Development.IDE.GHC.Compat(
+    getHeaderImports,
     HieFileResult(..),
     HieFile,
     hieExportNames,
@@ -46,7 +47,10 @@ import qualified Module
 
 import qualified GHC
 import GHC hiding (ClassOpSig, DerivD, ForD, IEThingAll, IEThingWith, InstD, TyClD, ValD, ModLocation)
+import qualified HeaderInfo as Hdr
 import Avail
+import ErrUtils (ErrorMessages)
+import FastString (FastString)
 
 #if MIN_GHC_API_VERSION(8,8,0)
 import Control.Applicative ((<|>))
@@ -69,6 +73,7 @@ import IfaceEnv
 #endif
 
 import Binary
+import Control.Exception (catch)
 import Data.ByteString (ByteString)
 import GhcPlugins hiding (ModLocation)
 import NameCache
@@ -250,3 +255,24 @@ readHieFile _ _ = return undefined
 #endif
 
 #endif
+
+getHeaderImports
+  :: DynFlags
+  -> StringBuffer
+  -> FilePath
+  -> FilePath
+  -> IO
+       ( Either
+           ErrorMessages
+           ( [(Maybe FastString, Located ModuleName)]
+           , [(Maybe FastString, Located ModuleName)]
+           , Located ModuleName
+           )
+       )
+#if MIN_GHC_API_VERSION(8,8,0)
+getHeaderImports = Hdr.getImports
+#else
+getHeaderImports a b c d =
+    catch (Right <$> Hdr.getImports a b c d)
+          (return . Left . srcErrorMessages)
+#endif

src/Development/IDE/GHC/Error.hs

@@ -9,6 +9,7 @@ module Development.IDE.GHC.Error
   , diagFromStrings
   , diagFromGhcException
   , catchSrcErrors
+  , mergeDiagnostics
 
   -- * utilities working with spans
   , srcSpanToLocation
@@ -36,6 +37,7 @@ import Panic
 import           ErrUtils
 import           SrcLoc
 import qualified Outputable                 as Out
+import Exception (ExceptionMonad)
 
 
 
@@ -61,6 +63,25 @@ diagFromErrMsg diagSource dflags e =
 diagFromErrMsgs :: T.Text -> DynFlags -> Bag ErrMsg -> [FileDiagnostic]
 diagFromErrMsgs diagSource dflags = concatMap (diagFromErrMsg diagSource dflags) . bagToList
 
+-- | Merges two sorted lists of diagnostics, removing duplicates.
+--   Assumes all the diagnostics are for the same file.
+mergeDiagnostics :: [FileDiagnostic] -> [FileDiagnostic] -> [FileDiagnostic]
+mergeDiagnostics aa [] = aa
+mergeDiagnostics [] bb = bb
+mergeDiagnostics (a@(_,_,ad@Diagnostic{_range = ar}):aa) (b@(_,_,bd@Diagnostic{_range=br}):bb)
+  | ar < br
+  = a : mergeDiagnostics aa (b:bb)
+  | br < ar
+  = b : mergeDiagnostics (a:aa) bb
+  | _severity ad == _severity bd
+  && _source ad == _source bd
+  && _message ad == _message bd
+  && _code ad == _code bd
+  && _relatedInformation ad == _relatedInformation bd
+  && _tags ad == _tags bd
+  = a : mergeDiagnostics aa bb
+  | otherwise
+  = a : b : mergeDiagnostics aa bb
 
 -- | Convert a GHC SrcSpan to a DAML compiler Range
 srcSpanToRange :: SrcSpan -> Range
@@ -128,7 +149,7 @@ realSpan = \case
 
 -- | Run something in a Ghc monad and catch the errors (SourceErrors and
 -- compiler-internal exceptions like Panic or InstallationError).
-catchSrcErrors :: GhcMonad m => T.Text -> m a -> m (Either [FileDiagnostic] a)
+catchSrcErrors :: (HasDynFlags m, ExceptionMonad m) => T.Text -> m a -> m (Either [FileDiagnostic] a)
 catchSrcErrors fromWhere ghcM = do
       dflags <- getDynFlags
       handleGhcException (ghcExceptionToDiagnostics dflags) $

src/Development/IDE/GHC/Orphans.hs

@@ -31,7 +31,7 @@ instance NFData Linkable where rnf = rwhnf
 instance Show InstalledUnitId where
     show = installedUnitIdString
 
-instance NFData InstalledUnitId where rnf = rwhnf
+instance NFData InstalledUnitId where rnf = rwhnf . installedUnitIdFS
 
 instance NFData SB.StringBuffer where rnf = rwhnf
 
@@ -40,8 +40,8 @@ instance Show Module where
 
 instance Show (GenLocated SrcSpan ModuleName) where show = prettyPrint
 
-instance NFData (GenLocated SrcSpan ModuleName) where
-    rnf = rwhnf
+instance (NFData l, NFData e) => NFData (GenLocated l e) where
+    rnf (L l e) = rnf l `seq` rnf e
 
 instance Show ModSummary where
     show = show . ms_mod
@@ -52,6 +52,9 @@ instance Show ParsedModule where
 instance NFData ModSummary where
     rnf = rwhnf
 
+instance NFData FastString where
+    rnf = rwhnf
+
 instance NFData ParsedModule where
     rnf = rwhnf
 

src/Development/IDE/GHC/Util.hs

@@ -147,22 +147,20 @@ runGhcEnv env act = do
 -- | Given a module location, and its parse tree, figure out what is the include directory implied by it.
 --   For example, given the file @\/usr\/\Test\/Foo\/Bar.hs@ with the module name @Foo.Bar@ the directory
 --   @\/usr\/Test@ should be on the include path to find sibling modules.
-moduleImportPath :: NormalizedFilePath -> GHC.ParsedModule -> Maybe FilePath
+moduleImportPath :: NormalizedFilePath -> GHC.ModuleName -> Maybe FilePath
 -- The call to takeDirectory is required since DAML does not require that
 -- the file name matches the module name in the last component.
 -- Once that has changed we can get rid of this.
-moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) pm
+moduleImportPath (takeDirectory . fromNormalizedFilePath -> pathDir) mn
     -- This happens for single-component modules since takeDirectory "A" == "."
     | modDir == "." = Just pathDir
     | otherwise = dropTrailingPathSeparator <$> stripSuffix modDir pathDir
   where
-    ms   = GHC.pm_mod_summary pm
-    mod'  = GHC.ms_mod ms
     -- A for module A.B
     modDir =
         takeDirectory $
         fromNormalizedFilePath $ toNormalizedFilePath' $
-        moduleNameSlashes $ GHC.moduleName mod'
+        moduleNameSlashes mn
 
 -- | An 'HscEnv' with equality. Two values are considered equal
 --   if they are created with the same call to 'newHscEnvEq'.

src/Development/IDE/GHC/WithDynFlags.hs

@@ -0,0 +1,30 @@
+module Development.IDE.GHC.WithDynFlags
+( WithDynFlags
+, evalWithDynFlags
+) where
+
+import Control.Monad.Trans.Reader (ask, ReaderT(..))
+import GHC (DynFlags)
+import Control.Monad.IO.Class (MonadIO)
+import Exception (ExceptionMonad(..))
+import Control.Monad.Trans.Class (MonadTrans(..))
+import GhcPlugins (HasDynFlags(..))
+
+-- | A monad transformer implementing the 'HasDynFlags' effect
+newtype WithDynFlags m a = WithDynFlags {withDynFlags :: ReaderT DynFlags m a}
+  deriving (Applicative, Functor, Monad, MonadIO, MonadTrans)
+
+evalWithDynFlags :: DynFlags -> WithDynFlags m a -> m a
+evalWithDynFlags dflags = flip runReaderT dflags . withDynFlags
+
+instance Monad m => HasDynFlags (WithDynFlags m) where
+    getDynFlags = WithDynFlags ask
+
+instance ExceptionMonad m => ExceptionMonad (WithDynFlags m) where
+    gmask f = WithDynFlags $ ReaderT $ \env ->
+        gmask $ \restore ->
+            let restore' = lift . restore . flip runReaderT env . withDynFlags
+            in runReaderT (withDynFlags $ f restore') env
+
+    gcatch (WithDynFlags act) handle = WithDynFlags $ ReaderT $ \env ->
+        gcatch (runReaderT act env) (flip runReaderT env . withDynFlags . handle)

src/Development/IDE/Plugin/Completions.hs

@@ -1,9 +1,10 @@
+{-# LANGUAGE CPP          #-}
 {-# LANGUAGE TypeFamilies #-}
+#include "ghc-api-version.h"
 
 module Development.IDE.Plugin.Completions(plugin) where
 
 import Control.Applicative
-import Data.Maybe
 import Language.Haskell.LSP.Messages
 import Language.Haskell.LSP.Types
 import qualified Language.Haskell.LSP.Core as LSP
@@ -22,8 +23,11 @@ import Development.IDE.Core.RuleTypes
 import Development.IDE.Core.Shake
 import Development.IDE.GHC.Util
 import Development.IDE.LSP.Server
-import Development.IDE.Import.DependencyInformation
 
+#if !MIN_GHC_API_VERSION(8,6,0) || defined(GHC_LIB)
+import Data.Maybe
+import Development.IDE.Import.DependencyInformation
+#endif
 
 plugin :: Plugin c
 plugin = Plugin produceCompletions setHandlersCompletion
@@ -31,8 +35,15 @@ plugin = Plugin produceCompletions setHandlersCompletion
 produceCompletions :: Rules ()
 produceCompletions =
     define $ \ProduceCompletions file -> do
+
+-- When possible, rely on the haddocks embedded in our interface files
+-- This creates problems on ghc-lib, see comment on 'getDocumentationTryGhc'
+#if MIN_GHC_API_VERSION(8,6,0) && !defined(GHC_LIB)
+        let parsedDeps = []
+#else
         deps <- maybe (TransitiveDependencies [] [] []) fst <$> useWithStale GetDependencies file
         parsedDeps <- mapMaybe (fmap fst) <$> usesWithStale GetParsedModule (transitiveModuleDeps deps)
+#endif
         tm <- fmap fst <$> useWithStale TypeCheck file
         packageState <- fmap (hscEnv . fst) <$> useWithStale GhcSession file
         case (tm, packageState) of

src/Development/IDE/Spans/Calculate.hs

@@ -52,29 +52,31 @@ getSrcSpanInfos
     :: HscEnv
     -> [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ Dependencies in topological order
     -> TcModuleResult
-    -> [(ParsedModule, ModIface)]
+    -> [ParsedModule]   -- ^ Dependencies parsed, optional
+    -> [ModIface]       -- ^ Dependencies module interfaces, required
     -> IO SpansInfo
-getSrcSpanInfos env imports tc deps =
+getSrcSpanInfos env imports tc parsedDeps deps =
     evalGhcEnv env $
-        getSpanInfo imports (tmrModule tc) deps
+        getSpanInfo imports (tmrModule tc) parsedDeps deps
 
 -- | Get ALL source spans in the module.
 getSpanInfo :: GhcMonad m
             => [(Located ModuleName, Maybe NormalizedFilePath)] -- ^ imports
             -> TypecheckedModule
-            -> [(ParsedModule, ModIface)]
+            -> [ParsedModule]
+            -> [ModIface]
             -> m SpansInfo
-getSpanInfo mods tcm@TypecheckedModule{..} deps =
+getSpanInfo mods tcm@TypecheckedModule{..} parsedDeps deps =
   do let tcs = tm_typechecked_source
          bs  = listifyAllSpans  tcs :: [LHsBind GhcTc]
          es  = listifyAllSpans  tcs :: [LHsExpr GhcTc]
          ps  = listifyAllSpans' tcs :: [Pat GhcTc]
          ts  = listifyAllSpans tm_renamed_source :: [LHsType GhcRn]
-         allModules = tm_parsed_module : map fst deps
+         allModules = tm_parsed_module : parsedDeps
          funBinds = funBindMap tm_parsed_module
 
      -- Load all modules in HPT to make their interface documentation available
-     mapM_ ((`loadDepModule` Nothing) . snd) (reverse deps)
+     mapM_ (`loadDepModule` Nothing) (reverse deps)
      forM_ (modInfoIface tm_checked_module_info) $ \modIface ->
        modifySession (loadModuleHome $ HomeModInfo modIface (snd tm_internals_) Nothing)
 

test/exe/Main.hs

@@ -1,6 +1,7 @@
 -- Copyright (c) 2019 The DAML Authors. All rights reserved.
 -- SPDX-License-Identifier: Apache-2.0
 
+{-# LANGUAGE AllowAmbiguousTypes   #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE CPP #-}
@@ -12,7 +13,7 @@ import Control.Applicative.Combinators
 import Control.Exception (catch)
 import Control.Monad
 import Control.Monad.IO.Class (liftIO)
-import Data.Aeson (Value)
+import Data.Aeson (FromJSON, Value)
 import Data.Char (toLower)
 import Data.Foldable
 import Data.List
@@ -21,6 +22,7 @@ import qualified Data.Rope.UTF16 as Rope
 import Development.IDE.Core.PositionMapping (fromCurrent, toCurrent)
 import Development.IDE.GHC.Util
 import qualified Data.Text as T
+import Data.Typeable
 import Development.IDE.Spans.Common
 import Development.IDE.Test
 import Development.IDE.Test.Runfiles
@@ -410,6 +412,19 @@ diagnosticTests = testGroup "diagnostics"
           liftIO $ unless ("redundant" `T.isInfixOf` msg) $
               assertFailure ("Expected redundant import but got " <> T.unpack msg)
           closeDoc a
+  , testSessionWait "haddock parse error" $ do
+      let fooContent = T.unlines
+            [ "module Foo where"
+            , "foo :: Int"
+            , "foo = 1 {-|-}"
+            ]
+      _ <- openDoc' "Foo.hs" "haskell" fooContent
+      expectDiagnostics
+        [ ( "Foo.hs"
+          , [(DsError, (2, 8), "Parse error on input")
+            ]
+          )
+        ]
   ]
 
 codeActionTests :: TestTree
@@ -436,24 +451,28 @@ watchedFilesTests :: TestTree
 watchedFilesTests = testGroup "watched files"
   [ testSession' "workspace files" $ \sessionDir -> do
       liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-isrc\"]}}"
-      _ <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport B"
-      watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
+      _doc <- openDoc' "A.hs" "haskell" "{-#LANGUAGE NoImplicitPrelude #-}\nmodule A where\nimport WatchedFilesMissingModule"
+      watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
 
       -- Expect 6 subscriptions (A does not get any because it's VFS):
-      --  - /path-to-workspace/B.hs
-      --  - /path-to-workspace/B.lhs
-      --  - B.hs
-      --  - B.lhs
-      --  - src/B.hs
-      --  - src/B.lhs
+      --  - /path-to-workspace/WatchedFilesMissingModule.hs
+      --  - /path-to-workspace/WatchedFilesMissingModule.lhs
+      --  - WatchedFilesMissingModule.hs
+      --  - WatchedFilesMissingModule.lhs
+      --  - src/WatchedFilesMissingModule.hs
+      --  - src/WatchedFilesMissingModule.lhs
       liftIO $ length watchedFileRegs @?= 6
 
   , testSession' "non workspace file" $ \sessionDir -> do
       liftIO $ writeFile (sessionDir </> "hie.yaml") $ "cradle: {direct: {arguments: [\"-i/tmp\"]}}"
-      _ <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport B"
-      watchedFileRegs <- getWatchedFilesSubscriptionsUntilProgressEnd
+      _doc <- openDoc' "A.hs" "haskell" "{-# LANGUAGE NoImplicitPrelude#-}\nmodule A where\nimport WatchedFilesMissingModule"
+      watchedFileRegs <- getWatchedFilesSubscriptionsUntil @PublishDiagnosticsNotification
 
-      -- Expect 4 subscriptions:
+      -- Expect 4 subscriptions (/tmp does not get any as it is out of the workspace):
+      --  - /path-to-workspace/WatchedFilesMissingModule.hs
+      --  - /path-to-workspace/WatchedFilesMissingModule.lhs
+      --  - WatchedFilesMissingModule.hs
+      --  - WatchedFilesMissingModule.lhs
       liftIO $ length watchedFileRegs @?= 4
 
   -- TODO add a test for didChangeWorkspaceFolder
@@ -2323,9 +2342,9 @@ nthLine i r
     | i >= Rope.rows r = error $ "Row number out of bounds: " <> show i <> "/" <> show (Rope.rows r)
     | otherwise = Rope.takeWhile (/= '\n') $ fst $ Rope.splitAtLine 1 $ snd $ Rope.splitAtLine (i - 1) r
 
-getWatchedFilesSubscriptionsUntilProgressEnd :: Session [Maybe Value]
-getWatchedFilesSubscriptionsUntilProgressEnd = do
-      msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @WorkDoneProgressEndNotification)
+getWatchedFilesSubscriptionsUntil :: forall end . (FromJSON end, Typeable end) => Session [Maybe Value]
+getWatchedFilesSubscriptionsUntil = do
+      msgs <- manyTill (Just <$> message @RegisterCapabilityRequest <|> Nothing <$ anyMessage) (message @end)
       return
             [ args
             | Just (RequestMessage{_params = RegistrationParams (List regs)}) <- msgs