Simplify and deduplicate ModSummary logic (#884)

* Simplify and dedup parsing logic * delete removePackageImports * add dependencies on included files * hlint
haskell · Oct 27, 2020 · 933c0c9 · 933c0c9
1 parent abf0a8a
commit 933c0c9
Show file tree

Hide file tree

Showing 2 changed files with 66 additions and 125 deletions.
diff --git a/src/Development/IDE/Core/Compile.hs b/src/Development/IDE/Core/Compile.hs
@@ -13,7 +13,6 @@ module Development.IDE.Core.Compile
   , RunSimplifier(..)
   , compileModule
   , parseModule
-  , parseHeader
   , typecheckModule
   , computePackageDeps
   , addRelativeImport
@@ -41,7 +40,6 @@ import Development.IDE.GHC.Warnings
 import Development.IDE.Types.Diagnostics
 import Development.IDE.GHC.Orphans()
 import Development.IDE.GHC.Util
-import qualified GHC.LanguageExtensions.Type as GHC
 import Development.IDE.Types.Options
 import Development.IDE.Types.Location
 
@@ -67,7 +65,6 @@ import qualified Development.IDE.GHC.Compat     as GHC
 import qualified Development.IDE.GHC.Compat     as Compat
 import           GhcMonad
 import           GhcPlugins                     as GHC hiding (fst3, (<>))
-import qualified HeaderInfo                     as Hdr
 import           HscMain                        (makeSimpleDetails, hscDesugar, hscTypecheckRename, hscSimplify, hscGenHardCode, hscInteractive)
 import           MkIface
 import           StringBuffer                   as SB
@@ -102,17 +99,14 @@ import Maybes (orElse)
 parseModule
     :: IdeOptions
     -> HscEnv
-    -> [PackageName]
     -> FilePath
-    -> UTCTime
-    -> Maybe SB.StringBuffer
-    -> IO (IdeResult (StringBuffer, ParsedModule))
-parseModule IdeOptions{..} env comp_pkgs filename modTime mbContents =
+    -> ModSummary
+    -> IO (IdeResult ParsedModule)
+parseModule IdeOptions{..} env filename ms =
     fmap (either (, Nothing) id) $
     runExceptT $ do
-        (contents, dflags) <- preprocessor env filename mbContents
-        (diag, modu) <- parseFileContents env optPreprocessor dflags comp_pkgs filename modTime contents
-        return (diag, Just (contents, modu))
+        (diag, modu) <- parseFileContents env optPreprocessor filename ms
+        return (diag, Just modu)
 
 
 -- | Given a package identifier, what packages does it depend on
@@ -483,70 +477,10 @@ loadModulesHome mod_infos e =
     where
       mod_name = moduleName . mi_module . hm_iface
 
--- | GhcMonad function to chase imports of a module given as a StringBuffer. Returns given module's
--- name and its imports.
-getImportsParsed ::  DynFlags ->
-               GHC.ParsedSource ->
-               Either [FileDiagnostic] (GHC.ModuleName, [(Bool, (Maybe FastString, Located GHC.ModuleName))])
-getImportsParsed dflags (L loc parsed) = do
-  let modName = maybe (GHC.mkModuleName "Main") GHC.unLoc $ GHC.hsmodName parsed
-
-  -- most of these corner cases are also present in https://hackage.haskell.org/package/ghc-8.6.1/docs/src/HeaderInfo.html#getImports
-  -- but we want to avoid parsing the module twice
-  let implicit_prelude = xopt GHC.ImplicitPrelude dflags
-      implicit_imports = Hdr.mkPrelImports modName loc implicit_prelude $ GHC.hsmodImports parsed
-
-  -- filter out imports that come from packages
-  return (modName, [(ideclSource i, (fmap sl_fs $ ideclPkgQual i, ideclName i))
-    | i <- map GHC.unLoc $ implicit_imports ++ GHC.hsmodImports parsed
-    , GHC.moduleNameString (GHC.unLoc $ ideclName i) /= "GHC.Prim"
-    ])
-
 withBootSuffix :: HscSource -> ModLocation -> ModLocation
 withBootSuffix HsBootFile = addBootSuffixLocnOut
 withBootSuffix _ = id
 
--- | Produce a module summary from a StringBuffer.
-getModSummaryFromBuffer
-    :: FilePath
-    -> UTCTime
-    -> DynFlags
-    -> GHC.ParsedSource
-    -> StringBuffer
-    -> ExceptT [FileDiagnostic] IO ModSummary
-getModSummaryFromBuffer fp modTime dflags parsed contents = do
-  (modName, imports) <- liftEither $ getImportsParsed dflags parsed
-
-  modLoc <- liftIO $ mkHomeModLocation dflags modName fp
-  let InstalledUnitId unitId = thisInstalledUnitId dflags
-  return $ ModSummary
-    { ms_mod          = mkModule (fsToUnitId unitId) modName
-    , ms_location     = withBootSuffix sourceType modLoc
-    , ms_hs_date      = modTime
-    , ms_textual_imps = [imp | (False, imp) <- imports]
-    , ms_hspp_file    = fp
-    , ms_hspp_opts    = dflags
-        -- NOTE: It's /vital/ we set the 'StringBuffer' here, to give any
-        -- registered GHC plugins access to the /updated/ in-memory content
-        -- of a module being edited. Without this line, any plugin wishing to
-        -- parse an input module and perform operations on the /current/ state
-        -- of a file wouldn't work properly, as it would \"see\" a stale view of
-        -- the file (i.e., the on-disk content of the latter).
-    , ms_hspp_buf     = Just contents
-
-    -- defaults:
-    , ms_hsc_src      = sourceType
-    , ms_obj_date     = Nothing
-    , ms_iface_date   = Nothing
-#if MIN_GHC_API_VERSION(8,8,0)
-    , ms_hie_date     = Nothing
-#endif
-    , ms_srcimps      = [imp | (True, imp) <- imports]
-    , ms_parsed_mod   = Nothing
-    }
-    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
@@ -650,17 +584,17 @@ parseHeader dflags filename contents = do
 
 -- | Given a buffer, flags, and file path, produce a
 -- parsed module (or errors) and any parse warnings. Does not run any preprocessors
+-- ModSummary must contain the (preprocessed) contents of the buffer
 parseFileContents
        :: HscEnv
        -> (GHC.ParsedSource -> IdePreprocessedSource)
-       -> DynFlags -- ^ flags to use
-       -> [PackageName] -- ^ The package imports to ignore
        -> FilePath  -- ^ the filename (for source locations)
-       -> UTCTime   -- ^ the modification timestamp
-       -> SB.StringBuffer -- ^ Haskell module source text (full Unicode is supported)
+       -> ModSummary
        -> ExceptT [FileDiagnostic] IO ([FileDiagnostic], ParsedModule)
-parseFileContents env customPreprocessor dflags comp_pkgs filename modTime contents = do
+parseFileContents env customPreprocessor filename ms = do
    let loc  = mkRealSrcLoc (mkFastString filename) 1 1
+       dflags = ms_hspp_opts ms
+       contents = fromJust $ ms_hspp_buf ms
    case unP Parser.parseModule (mkPState dflags contents loc) of
 #if MIN_GHC_API_VERSION(8,10,0)
      PFailed pst -> throwE $ diagFromErrMsgs "parser" dflags $ getErrorMessages pst dflags
@@ -690,33 +624,49 @@ parseFileContents env customPreprocessor dflags comp_pkgs filename modTime conte
 
                -- Ok, we got here. It's safe to continue.
                let IdePreprocessedSource preproc_warns errs parsed = customPreprocessor rdr_module
-               unless (null errs) $ throwE $ diagFromStrings "parser" DsError errs
-               let parsed' = removePackageImports comp_pkgs parsed
+
+               unless (null errs) $
+                  throwE $ diagFromStrings "parser" DsError errs
+
                let preproc_warnings = diagFromStrings "parser" DsWarning preproc_warns
-               ms <- getModSummaryFromBuffer filename modTime dflags parsed' contents
-               parsed'' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed
+               parsed' <- liftIO $ applyPluginsParsedResultAction env dflags ms hpm_annotations parsed
+
+               -- To get the list of extra source files, we take the list
+               -- that the parser gave us,
+               --   - eliminate files beginning with '<'.  gcc likes to use
+               --     pseudo-filenames like "<built-in>" and "<command-line>"
+               --   - normalise them (eliminate differences between ./f and f)
+               --   - filter out the preprocessed source file
+               --   - filter out anything beginning with tmpdir
+               --   - remove duplicates
+               --   - filter out the .hs/.lhs source filename if we have one
+               --
+               let n_hspp  = normalise filename
+                   srcs0 = nubOrd $ filter (not . (tmpDir dflags `isPrefixOf`))
+                                  $ filter (/= n_hspp)
+                                  $ map normalise
+                                  $ filter (not . isPrefixOf "<")
+                                  $ map unpackFS
+                                  $ srcfiles pst
+                   srcs1 = case ml_hs_file (ms_location ms) of
+                             Just f  -> filter (/= normalise f) srcs0
+                             Nothing -> srcs0
+
+               -- sometimes we see source files from earlier
+               -- preprocessing stages that cannot be found, so just
+               -- filter them out:
+               srcs2 <- liftIO $ filterM doesFileExist srcs1
+
                let pm =
                      ParsedModule {
                          pm_mod_summary = ms
-                       , pm_parsed_source = parsed''
-                       , pm_extra_src_files=[] -- src imports not allowed
+                       , pm_parsed_source = parsed'
+                       , pm_extra_src_files = srcs2
                        , pm_annotations = hpm_annotations
                       }
                    warnings = diagFromErrMsgs "parser" dflags warns
                pure (warnings ++ preproc_warnings, pm)
 
--- | After parsing the module remove all package imports referring to
--- these packages as we have already dealt with what they map to.
-removePackageImports :: [PackageName] -> GHC.ParsedSource -> GHC.ParsedSource
-removePackageImports pkgs (L l h@HsModule {hsmodImports} ) = L l (h { hsmodImports = imports' })
-  where
-    imports' = map do_one_import hsmodImports
-    do_one_import (L l i@ImportDecl{ideclPkgQual}) =
-      case PackageName . sl_fs <$> ideclPkgQual of
-        Just pn | pn `elem` pkgs -> L l (i { ideclPkgQual = Nothing })
-        _ -> L l i
-    do_one_import l = l
-
 loadHieFile :: Compat.NameCacheUpdater -> FilePath -> IO GHC.HieFile
 loadHieFile ncu f = do
   GHC.hie_file_result <$> GHC.readHieFile ncu f

diff --git a/src/Development/IDE/Core/Rules.hs b/src/Development/IDE/Core/Rules.hs
@@ -69,7 +69,6 @@ import           Language.Haskell.LSP.Types (DocumentHighlight (..))
 
 import qualified GHC.LanguageExtensions as LangExt
 import HscTypes hiding (TargetModule, TargetFile)
-import PackageConfig
 import DynFlags (gopt_set, xopt)
 import GHC.Generics(Generic)
 
@@ -266,24 +265,20 @@ priorityFilesOfInterest = Priority (-2)
 -- and https://github.com/mpickering/ghcide/pull/22#issuecomment-625070490
 getParsedModuleRule :: Rules ()
 getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
-    _ <- use_ GetModSummaryWithoutTimestamps file -- Fail if we can't even parse the ModSummary
+    (ms, _) <- use_ GetModSummary file
     sess <- use_ GhcSession file
     let hsc = hscEnv sess
-        -- These packages are used when removing PackageImports from a
-        -- parsed module
-        comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
     opt <- getIdeOptions
-    (modTime, contents) <- getFileContents file
 
-    let dflags    = hsc_dflags hsc
-        mainParse = getParsedModuleDefinition hsc opt comp_pkgs file modTime contents
+    let dflags    = ms_hspp_opts ms
+        mainParse = getParsedModuleDefinition hsc opt file ms
 
     -- Parse again (if necessary) to capture Haddock parse errors
-    if gopt Opt_Haddock dflags
+    res@(_, (_,pmod)) <- if gopt Opt_Haddock dflags
         then
             liftIO mainParse
         else do
-            let haddockParse = getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs file modTime contents
+            let haddockParse = getParsedModuleDefinition hsc opt file (withOptHaddock ms)
 
             -- parse twice, with and without Haddocks, concurrently
             -- we cannot ignore Haddock parse errors because files of
@@ -305,10 +300,12 @@ getParsedModuleRule = defineEarlyCutoff $ \GetParsedModule file -> do
               -- This seems to be the correct behaviour because the Haddock flag is added
               -- by us and not the user, so our IDE shouldn't stop working because of it.
               _ -> pure (fp, (diagsM, res))
+    -- Add dependencies on included files
+    _ <- uses GetModificationTime $ map toNormalizedFilePath' (maybe [] pm_extra_src_files pmod)
+    pure res
 
-
-withOptHaddock :: HscEnv -> HscEnv
-withOptHaddock hsc = hsc{hsc_dflags = gopt_set (hsc_dflags hsc) Opt_Haddock}
+withOptHaddock :: ModSummary -> ModSummary
+withOptHaddock ms = ms{ms_hspp_opts= gopt_set (ms_hspp_opts ms) Opt_Haddock}
 
 
 -- | Given some normal parse errors (first) and some from Haddock (second), merge them.
@@ -323,17 +320,14 @@ mergeParseErrorsHaddock normal haddock = normal ++
     fixMessage x | "parse error " `T.isPrefixOf` x = "Haddock " <> x
                  | otherwise = "Haddock: " <> x
 
-getParsedModuleDefinition :: HscEnv -> IdeOptions -> [PackageName] -> NormalizedFilePath -> UTCTime -> Maybe T.Text -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
-getParsedModuleDefinition packageState opt comp_pkgs file modTime contents = do
+getParsedModuleDefinition :: HscEnv -> IdeOptions -> NormalizedFilePath -> ModSummary -> IO (Maybe ByteString, ([FileDiagnostic], Maybe ParsedModule))
+getParsedModuleDefinition packageState opt file ms = do
     let fp = fromNormalizedFilePath file
-        buffer = textToStringBuffer <$> contents
-    (diag, res) <- parseModule opt packageState comp_pkgs fp modTime buffer
+    (diag, res) <- parseModule opt packageState fp ms
     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
+        Just modu -> do
+            mbFingerprint <- traverse (fmap fingerprintToBS . fingerprintFromStringBuffer) (ms_hspp_buf ms)
             pure (mbFingerprint, (diag, Just modu))
 
 getLocatedImportsRule :: Rules ()
@@ -710,7 +704,7 @@ getModIfaceFromDiskRule = defineEarlyCutoff $ \GetModIfaceFromDisk f -> do
       Just session -> do
         sourceModified <- use_ IsHiFileStable f
         linkableType <- getLinkableType f
-        r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f)
+        r <- loadInterface (hscEnv session) ms sourceModified linkableType (regenerateHiFile session f ms)
         case r of
             (diags, Just x) -> do
                 let fp = Just (hiFileFingerPrint x)
@@ -837,22 +831,18 @@ getModIfaceWithoutLinkableRule = defineEarlyCutoff $ \GetModIfaceWithoutLinkable
       msg = "tried to look at linkable for GetModIfaceWithoutLinkable for " ++ show f
   pure (fingerprintToBS . getModuleHash . hirModIface <$> mhfr', ([],mhfr'))
 
-regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult)
-regenerateHiFile sess f compNeeded = do
+regenerateHiFile :: HscEnvEq -> NormalizedFilePath -> ModSummary -> Maybe LinkableType -> Action ([FileDiagnostic], Maybe HiFileResult)
+regenerateHiFile sess f ms compNeeded = do
     let hsc = hscEnv sess
-        -- After parsing the module remove all package imports referring to
-        -- these packages as we have already dealt with what they map to.
-        comp_pkgs = mapMaybe (fmap fst . mkImportDirs (hsc_dflags hsc)) (deps sess)
     opt <- getIdeOptions
-    (modTime, contents) <- getFileContents f
 
     -- Embed haddocks in the interface file
-    (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition (withOptHaddock hsc) opt comp_pkgs f modTime contents
+    (_, (diags, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f (withOptHaddock ms)
     (diags, mb_pm) <- case mb_pm of
         Just _ -> return (diags, mb_pm)
         Nothing -> do
             -- if parsing fails, try parsing again with Haddock turned off
-            (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt comp_pkgs f modTime contents
+            (_, (diagsNoHaddock, mb_pm)) <- liftIO $ getParsedModuleDefinition hsc opt f ms
             return (mergeParseErrorsHaddock diagsNoHaddock diags, mb_pm)
     case mb_pm of
         Nothing -> return (diags, Nothing)
@@ -879,8 +869,9 @@ regenerateHiFile sess f compNeeded = do
 
                 -- Write hie file
                 (gDiags, masts) <- liftIO $ generateHieAsts hsc tmr
+                source <- getSourceFileSource f
                 wDiags <- forM masts $ \asts ->
-                  liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts $ maybe "" T.encodeUtf8 contents
+                  liftIO $ writeHieFile hsc (tmrModSummary tmr) (tcg_exports $ tmrTypechecked tmr) asts source
 
                 return (diags <> diags' <> diags'' <> hiDiags <> gDiags <> concat wDiags, res)