Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb-25-07 at Glasgow Haskell Compiler / GHC
Commits:
-
804668b0
by Torsten Schmits at 2025-12-11T18:16:51+01:00
-
5d0bf8f5
by Torsten Schmits at 2025-12-11T18:16:51+01:00
-
778e89ac
by Torsten Schmits at 2025-12-11T18:16:51+01:00
22 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Rename/Names.hs
- compiler/GHC/Runtime/Context.hs
- compiler/GHC/Runtime/Loader.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Utils/Monad.hs
- compiler/GHC/Types/Name/Ppr.hs
- compiler/GHC/Unit/Env.hs
- compiler/GHC/Unit/Finder.hs
- compiler/GHC/Unit/State.hs
- ghc/GHCi/UI.hs
- ghc/GHCi/UI/Monad.hs
- ghc/Main.hs
Changes:
| ... | ... | @@ -341,7 +341,7 @@ import GHC.Builtin.Types.Prim ( alphaTyVars ) |
| 341 | 341 | import GHC.Data.StringBuffer
|
| 342 | 342 | import GHC.Data.FastString
|
| 343 | 343 | import qualified GHC.LanguageExtensions as LangExt
|
| 344 | -import GHC.Rename.Names (renamePkgQual, renameRawPkgQual, gresFromAvails)
|
|
| 344 | +import GHC.Rename.Names (gresFromAvails, hscRenamePkgQual, hscRenameRawPkgQual)
|
|
| 345 | 345 | |
| 346 | 346 | import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
|
| 347 | 347 | import GHC.Tc.Types
|
| ... | ... | @@ -625,7 +625,8 @@ setUnitDynFlagsNoCheck uid dflags1 = do |
| 625 | 625 | |
| 626 | 626 | let old_hue = ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)
|
| 627 | 627 | let cached_unit_dbs = homeUnitEnv_unit_dbs old_hue
|
| 628 | - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
|
|
| 628 | + index <- hscUnitIndex <$> getSession
|
|
| 629 | + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 index cached_unit_dbs (hsc_all_home_unit_ids hsc_env)
|
|
| 629 | 630 | updated_dflags <- liftIO $ updatePlatformConstants dflags1 mconstants
|
| 630 | 631 | |
| 631 | 632 | let upd hue =
|
| ... | ... | @@ -760,6 +761,7 @@ setProgramDynFlags_ invalidate_needed dflags = do |
| 760 | 761 | then do
|
| 761 | 762 | -- additionally, set checked dflags so we don't lose fixes
|
| 762 | 763 | old_unit_env <- ue_setFlags dflags0 . hsc_unit_env <$> getSession
|
| 764 | + ue_index <- hscUnitIndex <$> getSession
|
|
| 763 | 765 | |
| 764 | 766 | home_unit_graph <- forM (ue_home_unit_graph old_unit_env) $ \homeUnitEnv -> do
|
| 765 | 767 | let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
|
| ... | ... | @@ -767,7 +769,7 @@ setProgramDynFlags_ invalidate_needed dflags = do |
| 767 | 769 | old_hpt = homeUnitEnv_hpt homeUnitEnv
|
| 768 | 770 | home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)
|
| 769 | 771 | |
| 770 | - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags cached_unit_dbs home_units
|
|
| 772 | + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags ue_index cached_unit_dbs home_units
|
|
| 771 | 773 | |
| 772 | 774 | updated_dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
|
| 773 | 775 | pure HomeUnitEnv
|
| ... | ... | @@ -785,6 +787,7 @@ setProgramDynFlags_ invalidate_needed dflags = do |
| 785 | 787 | , ue_home_unit_graph = home_unit_graph
|
| 786 | 788 | , ue_current_unit = ue_currentUnit old_unit_env
|
| 787 | 789 | , ue_eps = ue_eps old_unit_env
|
| 790 | + , ue_index
|
|
| 788 | 791 | }
|
| 789 | 792 | modifySession $ \h -> hscSetFlags dflags1 h{ hsc_unit_env = unit_env }
|
| 790 | 793 | else modifySession (hscSetFlags dflags0)
|
| ... | ... | @@ -1379,7 +1382,8 @@ getInsts = withSession $ \hsc_env -> |
| 1379 | 1382 | |
| 1380 | 1383 | getNamePprCtx :: GhcMonad m => m NamePprCtx
|
| 1381 | 1384 | getNamePprCtx = withSession $ \hsc_env -> do
|
| 1382 | - return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)
|
|
| 1385 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 1386 | + return $ icNamePprCtx (hsc_unit_env hsc_env) query (hsc_IC hsc_env)
|
|
| 1383 | 1387 | |
| 1384 | 1388 | -- | Container for information about a 'Module'.
|
| 1385 | 1389 | data ModuleInfo = ModuleInfo {
|
| ... | ... | @@ -1474,7 +1478,8 @@ mkNamePprCtxForModule :: |
| 1474 | 1478 | ModuleInfo ->
|
| 1475 | 1479 | m NamePprCtx
|
| 1476 | 1480 | mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do
|
| 1477 | - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
|
|
| 1481 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 1482 | + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))
|
|
| 1478 | 1483 | ptc = initPromotionTickContext (hsc_dflags hsc_env)
|
| 1479 | 1484 | return name_ppr_ctx
|
| 1480 | 1485 | |
| ... | ... | @@ -1711,10 +1716,10 @@ modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc d |
| 1711 | 1716 | parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))
|
| 1712 | 1717 | |
| 1713 | 1718 | renamePkgQualM :: GhcMonad m => ModuleName -> Maybe FastString -> m PkgQual
|
| 1714 | -renamePkgQualM mn p = withSession $ \hsc_env -> pure (renamePkgQual (hsc_unit_env hsc_env) mn p)
|
|
| 1719 | +renamePkgQualM mn p = withSession $ \hsc_env -> hscRenamePkgQual hsc_env mn p
|
|
| 1715 | 1720 | |
| 1716 | 1721 | renameRawPkgQualM :: GhcMonad m => ModuleName -> RawPkgQual -> m PkgQual
|
| 1717 | -renameRawPkgQualM mn p = withSession $ \hsc_env -> pure (renameRawPkgQual (hsc_unit_env hsc_env) mn p)
|
|
| 1722 | +renameRawPkgQualM mn p = withSession $ \hsc_env -> hscRenameRawPkgQual hsc_env mn p
|
|
| 1718 | 1723 | |
| 1719 | 1724 | -- | Like 'findModule', but differs slightly when the module refers to
|
| 1720 | 1725 | -- a source file, and the file has not been loaded via 'load'. In
|
| ... | ... | @@ -1738,7 +1743,8 @@ lookupQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do |
| 1738 | 1743 | let units = hsc_units hsc_env
|
| 1739 | 1744 | let dflags = hsc_dflags hsc_env
|
| 1740 | 1745 | let fopts = initFinderOpts dflags
|
| 1741 | - res <- findExposedPackageModule fc fopts units mod_name NoPkgQual
|
|
| 1746 | + query <- hscUnitIndexQuery hsc_env
|
|
| 1747 | + res <- findExposedPackageModule fc fopts units query mod_name NoPkgQual
|
|
| 1742 | 1748 | case res of
|
| 1743 | 1749 | Found _ m -> return m
|
| 1744 | 1750 | err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err
|
| ... | ... | @@ -78,6 +78,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod |
| 78 | 78 | , mg_rdr_env = rdr_env })
|
| 79 | 79 | = do { let builtin_passes = getCoreToDo dflags hpt_rule_base extra_vars
|
| 80 | 80 | uniq_tag = 's'
|
| 81 | + ; query <- hscUnitIndexQuery hsc_env
|
|
| 82 | + ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
|
|
| 81 | 83 | |
| 82 | 84 | ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_tag mod
|
| 83 | 85 | name_ppr_ctx loc $
|
| ... | ... | @@ -100,7 +102,6 @@ core2core hsc_env guts@(ModGuts { mg_module = mod |
| 100 | 102 | home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod
|
| 101 | 103 | , gwib_isBoot = NotBoot })
|
| 102 | 104 | hpt_rule_base = mkRuleBase home_pkg_rules
|
| 103 | - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
|
|
| 104 | 105 | ptc = initPromotionTickContext dflags
|
| 105 | 106 | -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.
|
| 106 | 107 | -- This is very convienent for the users of the monad (e.g. plugins do not have to
|
| ... | ... | @@ -459,6 +460,7 @@ doCorePass pass guts = do |
| 459 | 460 | dflags <- getDynFlags
|
| 460 | 461 | us <- getUniqueSupplyM
|
| 461 | 462 | p_fam_env <- getPackageFamInstEnv
|
| 463 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 462 | 464 | let platform = targetPlatform dflags
|
| 463 | 465 | let fam_envs = (p_fam_env, mg_fam_inst_env guts)
|
| 464 | 466 | let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) }
|
| ... | ... | @@ -471,6 +473,7 @@ doCorePass pass guts = do |
| 471 | 473 | mkNamePprCtx
|
| 472 | 474 | (initPromotionTickContext dflags)
|
| 473 | 475 | (hsc_unit_env hsc_env)
|
| 476 | + query
|
|
| 474 | 477 | rdr_env
|
| 475 | 478 | |
| 476 | 479 |
| ... | ... | @@ -429,6 +429,7 @@ addUnit u = do |
| 429 | 429 | logger <- getLogger
|
| 430 | 430 | let dflags0 = hsc_dflags hsc_env
|
| 431 | 431 | let old_unit_env = hsc_unit_env hsc_env
|
| 432 | + ue_index = hscUnitIndex hsc_env
|
|
| 432 | 433 | newdbs <- case ue_unit_dbs old_unit_env of
|
| 433 | 434 | Nothing -> panic "addUnit: called too early"
|
| 434 | 435 | Just dbs ->
|
| ... | ... | @@ -437,7 +438,7 @@ addUnit u = do |
| 437 | 438 | , unitDatabaseUnits = [u]
|
| 438 | 439 | }
|
| 439 | 440 | in return (dbs ++ [newdb]) -- added at the end because ordering matters
|
| 440 | - (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) (hsc_all_home_unit_ids hsc_env)
|
|
| 441 | + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
|
|
| 441 | 442 | |
| 442 | 443 | -- update platform constants
|
| 443 | 444 | dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
|
| ... | ... | @@ -452,6 +453,7 @@ addUnit u = do |
| 452 | 453 | (homeUnitId home_unit)
|
| 453 | 454 | (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
|
| 454 | 455 | , ue_eps = ue_eps old_unit_env
|
| 456 | + , ue_index
|
|
| 455 | 457 | }
|
| 456 | 458 | setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
|
| 457 | 459 | |
| ... | ... | @@ -870,6 +872,8 @@ hsModuleToModSummary home_keys pn hsc_src modname |
| 870 | 872 | hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
|
| 871 | 873 | hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
|
| 872 | 874 | |
| 875 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 876 | + |
|
| 873 | 877 | -- Also copied from 'getImports'
|
| 874 | 878 | let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
|
| 875 | 879 | |
| ... | ... | @@ -882,7 +886,7 @@ hsModuleToModSummary home_keys pn hsc_src modname |
| 882 | 886 | implicit_imports = mkPrelImports modname loc
|
| 883 | 887 | implicit_prelude imps
|
| 884 | 888 | |
| 885 | - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
|
|
| 889 | + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
|
|
| 886 | 890 | convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
|
| 887 | 891 | |
| 888 | 892 | extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
|
| ... | ... | @@ -7,6 +7,8 @@ module GHC.Driver.Env |
| 7 | 7 | , hsc_home_unit
|
| 8 | 8 | , hsc_home_unit_maybe
|
| 9 | 9 | , hsc_units
|
| 10 | + , hscUnitIndex
|
|
| 11 | + , hscUnitIndexQuery
|
|
| 10 | 12 | , hsc_HPT
|
| 11 | 13 | , hsc_HUE
|
| 12 | 14 | , hsc_HUG
|
| ... | ... | @@ -118,6 +120,13 @@ hsc_home_unit_maybe = ue_homeUnit . hsc_unit_env |
| 118 | 120 | hsc_units :: HasDebugCallStack => HscEnv -> UnitState
|
| 119 | 121 | hsc_units = ue_units . hsc_unit_env
|
| 120 | 122 | |
| 123 | +hscUnitIndex :: HscEnv -> UnitIndex
|
|
| 124 | +hscUnitIndex = ue_index . hsc_unit_env
|
|
| 125 | + |
|
| 126 | +hscUnitIndexQuery :: HscEnv -> IO UnitIndexQuery
|
|
| 127 | +hscUnitIndexQuery hsc_env =
|
|
| 128 | + unitIndexQuery (hscUnitIndex hsc_env) (hscActiveUnitId hsc_env)
|
|
| 129 | + |
|
| 121 | 130 | hsc_HPT :: HscEnv -> HomePackageTable
|
| 122 | 131 | hsc_HPT = ue_hpt . hsc_unit_env
|
| 123 | 132 |
| ... | ... | @@ -2665,9 +2665,10 @@ hscTidy hsc_env guts = do |
| 2665 | 2665 | $! {-# SCC "CoreTidy" #-} tidyProgram opts guts
|
| 2666 | 2666 | |
| 2667 | 2667 | -- post tidy pretty-printing and linting...
|
| 2668 | + query <- hscUnitIndexQuery hsc_env
|
|
| 2668 | 2669 | let tidy_rules = md_rules details
|
| 2669 | 2670 | let all_tidy_binds = cg_binds cgguts
|
| 2670 | - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
|
|
| 2671 | + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
|
|
| 2671 | 2672 | ptc = initPromotionTickContext (hsc_dflags hsc_env)
|
| 2672 | 2673 | |
| 2673 | 2674 | endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
|
| ... | ... | @@ -188,12 +188,13 @@ depanalE excluded_mods allow_dup_roots = do |
| 188 | 188 | if isEmptyMessages errs
|
| 189 | 189 | then do
|
| 190 | 190 | hsc_env <- getSession
|
| 191 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 191 | 192 | let one_unit_messages get_mod_errs k hue = do
|
| 192 | 193 | errs <- get_mod_errs
|
| 193 | 194 | unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
|
| 194 | 195 | |
| 195 | 196 | let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
|
| 196 | - unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
|
|
| 197 | + unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
|
|
| 197 | 198 | |
| 198 | 199 | |
| 199 | 200 | return $ errs `unionMessages` unused_home_mod_err
|
| ... | ... | @@ -511,15 +512,15 @@ loadWithCache cache diag_wrapper how_much = do |
| 511 | 512 | -- actually loaded packages. All the packages, specified on command line,
|
| 512 | 513 | -- but never loaded, are probably unused dependencies.
|
| 513 | 514 | |
| 514 | -warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
|
|
| 515 | -warnUnusedPackages us dflags mod_graph =
|
|
| 515 | +warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
|
|
| 516 | +warnUnusedPackages us query dflags mod_graph =
|
|
| 516 | 517 | let diag_opts = initDiagOpts dflags
|
| 517 | 518 | |
| 518 | 519 | home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
|
| 519 | 520 | |
| 520 | 521 | -- Only need non-source imports here because SOURCE imports are always HPT
|
| 521 | 522 | loadedPackages = concat $
|
| 522 | - mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
|
|
| 523 | + mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
|
|
| 523 | 524 | $ concatMap ms_imps home_mod_sum
|
| 524 | 525 | |
| 525 | 526 | any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
|
| ... | ... | @@ -2386,7 +2387,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do |
| 2386 | 2387 | mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
|
| 2387 | 2388 | let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
|
| 2388 | 2389 | pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
|
| 2389 | - let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
|
|
| 2390 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 2391 | + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
|
|
| 2390 | 2392 | let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
|
| 2391 | 2393 | let pi_srcimps = rn_imps pi_srcimps'
|
| 2392 | 2394 | let pi_theimps = rn_imps pi_theimps'
|
| ... | ... | @@ -692,9 +692,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do |
| 692 | 692 | -- gather the imports and module name
|
| 693 | 693 | (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
|
| 694 | 694 | buf <- hGetStringBuffer input_fn
|
| 695 | + query <- hscUnitIndexQuery hsc_env
|
|
| 695 | 696 | let imp_prelude = xopt LangExt.ImplicitPrelude dflags
|
| 696 | 697 | popts = initParserOpts dflags
|
| 697 | - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
|
|
| 698 | + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
|
|
| 698 | 699 | rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
|
| 699 | 700 | eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
|
| 700 | 701 | case eimps of
|
| ... | ... | @@ -149,7 +149,8 @@ deSugar hsc_env |
| 149 | 149 | = do { let dflags = hsc_dflags hsc_env
|
| 150 | 150 | logger = hsc_logger hsc_env
|
| 151 | 151 | ptc = initPromotionTickContext (hsc_dflags hsc_env)
|
| 152 | - name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env
|
|
| 152 | + ; query <- hscUnitIndexQuery hsc_env
|
|
| 153 | + ; let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env
|
|
| 153 | 154 | ; withTiming logger
|
| 154 | 155 | (text "Desugar"<+>brackets (ppr mod))
|
| 155 | 156 | (const ()) $
|
| ... | ... | @@ -89,6 +89,7 @@ import GHC.Data.FastString |
| 89 | 89 | |
| 90 | 90 | import GHC.Unit.Env
|
| 91 | 91 | import GHC.Unit.External
|
| 92 | +import GHC.Unit.State (UnitIndexQuery)
|
|
| 92 | 93 | import GHC.Unit.Module
|
| 93 | 94 | import GHC.Unit.Module.ModGuts
|
| 94 | 95 | |
| ... | ... | @@ -264,7 +265,8 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env |
| 264 | 265 | ++ eps_complete_matches eps -- from imports
|
| 265 | 266 | -- re-use existing next_wrapper_num to ensure uniqueness
|
| 266 | 267 | next_wrapper_num_var = tcg_next_wrapper_num tcg_env
|
| 267 | - ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
|
|
| 268 | + ; query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 269 | + ; return $ mkDsEnvs unit_env query this_mod rdr_env type_env fam_inst_env ptc
|
|
| 268 | 270 | msg_var cc_st_var next_wrapper_num_var complete_matches
|
| 269 | 271 | }
|
| 270 | 272 | |
| ... | ... | @@ -292,6 +294,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds |
| 292 | 294 | ; next_wrapper_num <- newIORef emptyModuleEnv
|
| 293 | 295 | ; msg_var <- newIORef emptyMessages
|
| 294 | 296 | ; eps <- liftIO $ hscEPS hsc_env
|
| 297 | + ; query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 295 | 298 | ; let unit_env = hsc_unit_env hsc_env
|
| 296 | 299 | type_env = typeEnvFromEntities ids tycons patsyns fam_insts
|
| 297 | 300 | ptc = initPromotionTickContext (hsc_dflags hsc_env)
|
| ... | ... | @@ -303,7 +306,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds |
| 303 | 306 | bindsToIds (Rec binds) = map fst binds
|
| 304 | 307 | ids = concatMap bindsToIds binds
|
| 305 | 308 | |
| 306 | - envs = mkDsEnvs unit_env this_mod rdr_env type_env
|
|
| 309 | + envs = mkDsEnvs unit_env query this_mod rdr_env type_env
|
|
| 307 | 310 | fam_inst_env ptc msg_var cc_st_var
|
| 308 | 311 | next_wrapper_num complete_matches
|
| 309 | 312 | ; runDs hsc_env envs thing_inside
|
| ... | ... | @@ -342,12 +345,12 @@ initTcDsForSolver thing_inside |
| 342 | 345 | Just ret -> pure ret
|
| 343 | 346 | Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }
|
| 344 | 347 | |
| 345 | -mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
|
|
| 348 | +mkDsEnvs :: UnitEnv -> UnitIndexQuery -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
|
|
| 346 | 349 | -> PromotionTickContext
|
| 347 | 350 | -> IORef (Messages DsMessage) -> IORef CostCentreState
|
| 348 | 351 | -> IORef (ModuleEnv Int) -> CompleteMatches
|
| 349 | 352 | -> (DsGblEnv, DsLclEnv)
|
| 350 | -mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
|
|
| 353 | +mkDsEnvs unit_env query mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
|
|
| 351 | 354 | next_wrapper_num complete_matches
|
| 352 | 355 | = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
|
| 353 | 356 | -- Failing tests here are `ghci` and `T11985` if you get this wrong.
|
| ... | ... | @@ -364,7 +367,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var |
| 364 | 367 | , ds_fam_inst_env = fam_inst_env
|
| 365 | 368 | , ds_gbl_rdr_env = rdr_env
|
| 366 | 369 | , ds_if_env = (if_genv, if_lenv)
|
| 367 | - , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env
|
|
| 370 | + , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env query rdr_env
|
|
| 368 | 371 | , ds_msgs = msg_var
|
| 369 | 372 | , ds_complete_matches = complete_matches
|
| 370 | 373 | , ds_cc_st = cc_st_var
|
| ... | ... | @@ -588,7 +588,8 @@ checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired |
| 588 | 588 | checkDependencies hsc_env summary iface
|
| 589 | 589 | = do
|
| 590 | 590 | res_normal <- classify_import (findImportedModule hsc_env) (ms_textual_imps summary ++ ms_srcimps summary)
|
| 591 | - res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units mhome_unit mod) (ms_plugin_imps summary)
|
|
| 591 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 592 | + res_plugin <- classify_import (\mod _ -> findPluginModule fc fopts units query mhome_unit mod) (ms_plugin_imps summary)
|
|
| 592 | 593 | case sequence (res_normal ++ res_plugin ++ [Right (fake_ghc_prim_import)| ms_ghc_prim_import summary]) of
|
| 593 | 594 | Left recomp -> return $ NeedsRecompile recomp
|
| 594 | 595 | Right es -> do
|
| ... | ... | @@ -27,6 +27,7 @@ module GHC.Rename.Names ( |
| 27 | 27 | getMinimalImports,
|
| 28 | 28 | printMinimalImports,
|
| 29 | 29 | renamePkgQual, renameRawPkgQual,
|
| 30 | + hscRenamePkgQual, hscRenameRawPkgQual,
|
|
| 30 | 31 | classifyGREs,
|
| 31 | 32 | ImportDeclUsage,
|
| 32 | 33 | ) where
|
| ... | ... | @@ -337,7 +338,8 @@ rnImportDecl this_mod |
| 337 | 338 | |
| 338 | 339 | hsc_env <- getTopEnv
|
| 339 | 340 | unit_env <- hsc_unit_env <$> getTopEnv
|
| 340 | - let pkg_qual = renameRawPkgQual unit_env imp_mod_name raw_pkg_qual
|
|
| 341 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 342 | + let pkg_qual = renameRawPkgQual unit_env query imp_mod_name raw_pkg_qual
|
|
| 341 | 343 | |
| 342 | 344 | -- Check for self-import, which confuses the typechecker (#9032)
|
| 343 | 345 | -- ghc --make rejects self-import cycles already, but batch-mode may not
|
| ... | ... | @@ -447,14 +449,14 @@ rnImportDecl this_mod |
| 447 | 449 | |
| 448 | 450 | |
| 449 | 451 | -- | Rename raw package imports
|
| 450 | -renameRawPkgQual :: UnitEnv -> ModuleName -> RawPkgQual -> PkgQual
|
|
| 451 | -renameRawPkgQual unit_env mn = \case
|
|
| 452 | +renameRawPkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> RawPkgQual -> PkgQual
|
|
| 453 | +renameRawPkgQual unit_env query mn = \case
|
|
| 452 | 454 | NoRawPkgQual -> NoPkgQual
|
| 453 | - RawPkgQual p -> renamePkgQual unit_env mn (Just (sl_fs p))
|
|
| 455 | + RawPkgQual p -> renamePkgQual unit_env query mn (Just (sl_fs p))
|
|
| 454 | 456 | |
| 455 | 457 | -- | Rename raw package imports
|
| 456 | -renamePkgQual :: UnitEnv -> ModuleName -> Maybe FastString -> PkgQual
|
|
| 457 | -renamePkgQual unit_env mn mb_pkg = case mb_pkg of
|
|
| 458 | +renamePkgQual :: UnitEnv -> UnitIndexQuery -> ModuleName -> Maybe FastString -> PkgQual
|
|
| 459 | +renamePkgQual unit_env query mn mb_pkg = case mb_pkg of
|
|
| 458 | 460 | Nothing -> NoPkgQual
|
| 459 | 461 | Just pkg_fs
|
| 460 | 462 | | Just uid <- homeUnitId <$> ue_homeUnit unit_env
|
| ... | ... | @@ -464,7 +466,7 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of |
| 464 | 466 | | Just (uid, _) <- find (fromMaybe False . fmap (== pkg_fs) . snd) home_names
|
| 465 | 467 | -> ThisPkg uid
|
| 466 | 468 | |
| 467 | - | Just uid <- resolvePackageImport (ue_units unit_env) mn (PackageName pkg_fs)
|
|
| 469 | + | Just uid <- resolvePackageImport (ue_units unit_env) query mn (PackageName pkg_fs)
|
|
| 468 | 470 | -> OtherPkg uid
|
| 469 | 471 | |
| 470 | 472 | | otherwise
|
| ... | ... | @@ -479,6 +481,25 @@ renamePkgQual unit_env mn mb_pkg = case mb_pkg of |
| 479 | 481 | hpt_deps :: [UnitId]
|
| 480 | 482 | hpt_deps = homeUnitDepends units
|
| 481 | 483 | |
| 484 | +hscRenameRawPkgQual ::
|
|
| 485 | + MonadIO m =>
|
|
| 486 | + HscEnv ->
|
|
| 487 | + ModuleName ->
|
|
| 488 | + RawPkgQual ->
|
|
| 489 | + m PkgQual
|
|
| 490 | +hscRenameRawPkgQual hsc_env name raw = do
|
|
| 491 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 492 | + pure (renameRawPkgQual (hsc_unit_env hsc_env) query name raw)
|
|
| 493 | + |
|
| 494 | +hscRenamePkgQual ::
|
|
| 495 | + MonadIO m =>
|
|
| 496 | + HscEnv ->
|
|
| 497 | + ModuleName ->
|
|
| 498 | + Maybe FastString ->
|
|
| 499 | + m PkgQual
|
|
| 500 | +hscRenamePkgQual hsc_env name package = do
|
|
| 501 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 502 | + pure (renamePkgQual (hsc_unit_env hsc_env) query name package)
|
|
| 482 | 503 | |
| 483 | 504 | -- | Calculate the 'ImportAvails' induced by an import of a particular
|
| 484 | 505 | -- interface, but without 'imp_mods'.
|
| ... | ... | @@ -26,6 +26,7 @@ import GHC.Runtime.Eval.Types ( IcGlobalRdrEnv(..), Resume ) |
| 26 | 26 | |
| 27 | 27 | import GHC.Unit
|
| 28 | 28 | import GHC.Unit.Env
|
| 29 | +import GHC.Unit.State (UnitIndexQuery)
|
|
| 29 | 30 | |
| 30 | 31 | import GHC.Core.FamInstEnv
|
| 31 | 32 | import GHC.Core.InstEnv
|
| ... | ... | @@ -351,8 +352,8 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt) |
| 351 | 352 | ]
|
| 352 | 353 | |
| 353 | 354 | -- | Get the NamePprCtx function based on the flags and this InteractiveContext
|
| 354 | -icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx
|
|
| 355 | -icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt)
|
|
| 355 | +icNamePprCtx :: UnitEnv -> UnitIndexQuery -> InteractiveContext -> NamePprCtx
|
|
| 356 | +icNamePprCtx unit_env query ictxt = mkNamePprCtx ptc unit_env query (icReaderEnv ictxt)
|
|
| 356 | 357 | where ptc = initPromotionTickContext (ic_dflags ictxt)
|
| 357 | 358 | |
| 358 | 359 | -- | extendInteractiveContext is called with new TyThings recently defined to update the
|
| ... | ... | @@ -348,7 +348,8 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do |
| 348 | 348 | let unit_state = ue_units unit_env
|
| 349 | 349 | let mhome_unit = hsc_home_unit_maybe hsc_env
|
| 350 | 350 | -- First find the unit the module resides in by searching exposed units and home modules
|
| 351 | - found_module <- findPluginModule fc fopts unit_state mhome_unit mod_name
|
|
| 351 | + query <- hscUnitIndexQuery hsc_env
|
|
| 352 | + found_module <- findPluginModule fc fopts unit_state query mhome_unit mod_name
|
|
| 352 | 353 | case found_module of
|
| 353 | 354 | Found _ mod -> do
|
| 354 | 355 | -- Find the exports of the module
|
| ... | ... | @@ -266,9 +266,11 @@ tcRnModuleTcRnM hsc_env mod_sum |
| 266 | 266 | ; when (notNull prel_imports) $ do
|
| 267 | 267 | addDiagnostic TcRnImplicitImportOfPrelude
|
| 268 | 268 | |
| 269 | + ; query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 270 | + |
|
| 269 | 271 | ; -- TODO This is a little skeevy; maybe handle a bit more directly
|
| 270 | 272 | let { simplifyImport (L _ idecl) =
|
| 271 | - ( renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName idecl) (ideclPkgQual idecl)
|
|
| 273 | + ( renameRawPkgQual (hsc_unit_env hsc_env) query (unLoc $ ideclName idecl) (ideclPkgQual idecl)
|
|
| 272 | 274 | , reLoc $ ideclName idecl)
|
| 273 | 275 | }
|
| 274 | 276 | ; raw_sig_imports <- liftIO
|
| ... | ... | @@ -1996,11 +1998,13 @@ runTcInteractive hsc_env thing_inside |
| 1996 | 1998 | (loadSrcInterface (text "runTcInteractive") m
|
| 1997 | 1999 | NotBoot mb_pkg)
|
| 1998 | 2000 | |
| 2001 | + |
|
| 1999 | 2002 | ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->
|
| 2000 | 2003 | case i of -- force above: see #15111
|
| 2001 | 2004 | IIModule n -> getOrphans n NoPkgQual
|
| 2002 | - IIDecl i -> getOrphans (unLoc (ideclName i))
|
|
| 2003 | - (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i))
|
|
| 2005 | + IIDecl i -> do
|
|
| 2006 | + qual <- hscRenameRawPkgQual hsc_env (unLoc $ ideclName i) (ideclPkgQual i)
|
|
| 2007 | + getOrphans (unLoc (ideclName i)) qual
|
|
| 2004 | 2008 | |
| 2005 | 2009 | ; let imports = emptyImportAvails { imp_orphs = orphs }
|
| 2006 | 2010 |
| ... | ... | @@ -869,7 +869,8 @@ getNamePprCtx |
| 869 | 869 | = do { ptc <- initPromotionTickContext <$> getDynFlags
|
| 870 | 870 | ; rdr_env <- getGlobalRdrEnv
|
| 871 | 871 | ; hsc_env <- getTopEnv
|
| 872 | - ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env }
|
|
| 872 | + ; query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 873 | + ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) query rdr_env }
|
|
| 873 | 874 | |
| 874 | 875 | -- | Like logInfoTcRn, but for user consumption
|
| 875 | 876 | printForUserTcRn :: SDoc -> TcRn ()
|
| ... | ... | @@ -68,11 +68,11 @@ with some holes, we should try to give the user some more useful information. |
| 68 | 68 | |
| 69 | 69 | -- | Creates some functions that work out the best ways to format
|
| 70 | 70 | -- names for the user according to a set of heuristics.
|
| 71 | -mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
|
|
| 72 | -mkNamePprCtx ptc unit_env env
|
|
| 71 | +mkNamePprCtx :: Outputable info => PromotionTickContext -> UnitEnv -> UnitIndexQuery -> GlobalRdrEnvX info -> NamePprCtx
|
|
| 72 | +mkNamePprCtx ptc unit_env index env
|
|
| 73 | 73 | = QueryQualify
|
| 74 | 74 | (mkQualName env)
|
| 75 | - (mkQualModule unit_state home_unit)
|
|
| 75 | + (mkQualModule unit_state index home_unit)
|
|
| 76 | 76 | (mkQualPackage unit_state)
|
| 77 | 77 | (mkPromTick ptc env)
|
| 78 | 78 | where
|
| ... | ... | @@ -206,8 +206,8 @@ Side note (int-index): |
| 206 | 206 | -- | Creates a function for formatting modules based on two heuristics:
|
| 207 | 207 | -- (1) if the module is the current module, don't qualify, and (2) if there
|
| 208 | 208 | -- is only one exposed package which exports this module, don't qualify.
|
| 209 | -mkQualModule :: UnitState -> Maybe HomeUnit -> QueryQualifyModule
|
|
| 210 | -mkQualModule unit_state mhome_unit mod
|
|
| 209 | +mkQualModule :: UnitState -> UnitIndexQuery -> Maybe HomeUnit -> QueryQualifyModule
|
|
| 210 | +mkQualModule unit_state index mhome_unit mod
|
|
| 211 | 211 | | Just home_unit <- mhome_unit
|
| 212 | 212 | , isHomeModule home_unit mod = False
|
| 213 | 213 | |
| ... | ... | @@ -218,7 +218,7 @@ mkQualModule unit_state mhome_unit mod |
| 218 | 218 | = False
|
| 219 | 219 | |
| 220 | 220 | | otherwise = True
|
| 221 | - where lookup = lookupModuleInAllUnits unit_state (moduleName mod)
|
|
| 221 | + where lookup = lookupModuleInAllUnits unit_state index (moduleName mod)
|
|
| 222 | 222 | |
| 223 | 223 | -- | Creates a function for formatting packages based on two heuristics:
|
| 224 | 224 | -- (1) don't qualify if the package in question is "main", and (2) only qualify
|
| ... | ... | @@ -100,6 +100,8 @@ data UnitEnv = UnitEnv |
| 100 | 100 | |
| 101 | 101 | , ue_namever :: !GhcNameVersion
|
| 102 | 102 | -- ^ GHC name/version (used for dynamic library suffix)
|
| 103 | + |
|
| 104 | + , ue_index :: !UnitIndex
|
|
| 103 | 105 | }
|
| 104 | 106 | |
| 105 | 107 | ueEPS :: UnitEnv -> IO ExternalPackageState
|
| ... | ... | @@ -108,12 +110,14 @@ ueEPS = eucEPS . ue_eps |
| 108 | 110 | initUnitEnv :: UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
|
| 109 | 111 | initUnitEnv cur_unit hug namever platform = do
|
| 110 | 112 | eps <- initExternalUnitCache
|
| 113 | + ue_index <- newUnitIndex
|
|
| 111 | 114 | return $ UnitEnv
|
| 112 | 115 | { ue_eps = eps
|
| 113 | 116 | , ue_home_unit_graph = hug
|
| 114 | 117 | , ue_current_unit = cur_unit
|
| 115 | 118 | , ue_platform = platform
|
| 116 | 119 | , ue_namever = namever
|
| 120 | + , ue_index
|
|
| 117 | 121 | }
|
| 118 | 122 | |
| 119 | 123 | -- | Get home-unit
|
| ... | ... | @@ -67,7 +67,7 @@ import Control.Monad |
| 67 | 67 | import Data.Time
|
| 68 | 68 | import qualified Data.Map as M
|
| 69 | 69 | import GHC.Driver.Env
|
| 70 | - ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env) )
|
|
| 70 | + ( hsc_home_unit_maybe, HscEnv(hsc_FC, hsc_dflags, hsc_unit_env, hsc_mod_graph), hscUnitIndexQuery )
|
|
| 71 | 71 | import GHC.Driver.Config.Finder
|
| 72 | 72 | import qualified Data.Set as Set
|
| 73 | 73 | import qualified Data.List.NonEmpty as NE
|
| ... | ... | @@ -162,17 +162,19 @@ findImportedModule hsc_env mod pkg_qual = |
| 162 | 162 | dflags = hsc_dflags hsc_env
|
| 163 | 163 | fopts = initFinderOpts dflags
|
| 164 | 164 | in do
|
| 165 | - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
|
|
| 165 | + query <- hscUnitIndexQuery hsc_env
|
|
| 166 | + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
|
|
| 166 | 167 | |
| 167 | 168 | findImportedModuleNoHsc
|
| 168 | 169 | :: FinderCache
|
| 169 | 170 | -> FinderOpts
|
| 170 | 171 | -> UnitEnv
|
| 172 | + -> UnitIndexQuery
|
|
| 171 | 173 | -> Maybe HomeUnit
|
| 172 | 174 | -> ModuleName
|
| 173 | 175 | -> PkgQual
|
| 174 | 176 | -> IO FindResult
|
| 175 | -findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
|
|
| 177 | +findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
|
|
| 176 | 178 | case mb_pkg of
|
| 177 | 179 | NoPkgQual -> unqual_import
|
| 178 | 180 | ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
|
| ... | ... | @@ -194,7 +196,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = |
| 194 | 196 | -- If the module is reexported, then look for it as if it was from the perspective
|
| 195 | 197 | -- of that package which reexports it.
|
| 196 | 198 | | mod_name `Set.member` finder_reexportedModules opts =
|
| 197 | - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
|
|
| 199 | + findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
|
|
| 198 | 200 | | mod_name `Set.member` finder_hiddenModules opts =
|
| 199 | 201 | return (mkHomeHidden uid)
|
| 200 | 202 | | otherwise =
|
| ... | ... | @@ -205,11 +207,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = |
| 205 | 207 | -- first before looking at the packages in order.
|
| 206 | 208 | any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
|
| 207 | 209 | |
| 208 | - pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
|
|
| 210 | + pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
|
|
| 209 | 211 | |
| 210 | 212 | unqual_import = any_home_import
|
| 211 | 213 | `orIfNotFound`
|
| 212 | - findExposedPackageModule fc fopts units mod_name NoPkgQual
|
|
| 214 | + findExposedPackageModule fc fopts units query mod_name NoPkgQual
|
|
| 213 | 215 | |
| 214 | 216 | units = case mhome_unit of
|
| 215 | 217 | Nothing -> ue_units ue
|
| ... | ... | @@ -222,13 +224,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = |
| 222 | 224 | -- plugin. This consults the same set of exposed packages as
|
| 223 | 225 | -- 'findImportedModule', unless @-hide-all-plugin-packages@ or
|
| 224 | 226 | -- @-plugin-package@ are specified.
|
| 225 | -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
|
|
| 226 | -findPluginModule fc fopts units (Just home_unit) mod_name =
|
|
| 227 | +findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
|
|
| 228 | +findPluginModule fc fopts units query (Just home_unit) mod_name =
|
|
| 227 | 229 | findHomeModule fc fopts home_unit mod_name
|
| 228 | 230 | `orIfNotFound`
|
| 229 | - findExposedPluginPackageModule fc fopts units mod_name
|
|
| 230 | -findPluginModule fc fopts units Nothing mod_name =
|
|
| 231 | - findExposedPluginPackageModule fc fopts units mod_name
|
|
| 231 | + findExposedPluginPackageModule fc fopts units query mod_name
|
|
| 232 | +findPluginModule fc fopts units query Nothing mod_name =
|
|
| 233 | + findExposedPluginPackageModule fc fopts units query mod_name
|
|
| 232 | 234 | |
| 233 | 235 | -- | Locate a specific 'Module'. The purpose of this function is to
|
| 234 | 236 | -- create a 'ModLocation' for a given 'Module', that is to find out
|
| ... | ... | @@ -284,15 +286,15 @@ homeSearchCache fc home_unit mod_name do_this = do |
| 284 | 286 | let mod = mkModule home_unit mod_name
|
| 285 | 287 | modLocationCache fc mod do_this
|
| 286 | 288 | |
| 287 | -findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
|
|
| 288 | -findExposedPackageModule fc fopts units mod_name mb_pkg =
|
|
| 289 | +findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
|
|
| 290 | +findExposedPackageModule fc fopts units query mod_name mb_pkg =
|
|
| 289 | 291 | findLookupResult fc fopts
|
| 290 | - $ lookupModuleWithSuggestions units mod_name mb_pkg
|
|
| 292 | + $ lookupModuleWithSuggestions units query mod_name mb_pkg
|
|
| 291 | 293 | |
| 292 | -findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
|
|
| 293 | -findExposedPluginPackageModule fc fopts units mod_name =
|
|
| 294 | +findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
|
|
| 295 | +findExposedPluginPackageModule fc fopts units query mod_name =
|
|
| 294 | 296 | findLookupResult fc fopts
|
| 295 | - $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
|
|
| 297 | + $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
|
|
| 296 | 298 | |
| 297 | 299 | findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
|
| 298 | 300 | findLookupResult fc fopts r = case r of
|
| 1 | 1 | -- (c) The University of Glasgow, 2006
|
| 2 | 2 | |
| 3 | -{-# LANGUAGE LambdaCase #-}
|
|
| 3 | +{-# LANGUAGE LambdaCase, RecordWildCards #-}
|
|
| 4 | 4 | |
| 5 | 5 | -- | Unit manipulation
|
| 6 | 6 | module GHC.Unit.State (
|
| ... | ... | @@ -49,6 +49,14 @@ module GHC.Unit.State ( |
| 49 | 49 | closeUnitDeps',
|
| 50 | 50 | mayThrowUnitErr,
|
| 51 | 51 | |
| 52 | + UnitConfig (..),
|
|
| 53 | + UnitIndex (..),
|
|
| 54 | + UnitIndexQuery (..),
|
|
| 55 | + UnitVisibility (..),
|
|
| 56 | + VisibilityMap,
|
|
| 57 | + ModuleNameProvidersMap,
|
|
| 58 | + newUnitIndex,
|
|
| 59 | + |
|
| 52 | 60 | -- * Module hole substitution
|
| 53 | 61 | ShHoleSubst,
|
| 54 | 62 | renameHoleUnit,
|
| ... | ... | @@ -218,7 +226,7 @@ instance Outputable ModuleOrigin where |
| 218 | 226 | (if null rhs
|
| 219 | 227 | then []
|
| 220 | 228 | else [text "hidden reexport by" <+>
|
| 221 | - sep (map (ppr . mkUnit) res)]) ++
|
|
| 229 | + sep (map (ppr . mkUnit) rhs)]) ++
|
|
| 222 | 230 | (if f then [text "package flag"] else [])
|
| 223 | 231 | ))
|
| 224 | 232 | |
| ... | ... | @@ -577,10 +585,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId) |
| 577 | 585 | -- | Find the UnitId which an import qualified by a package import comes from.
|
| 578 | 586 | -- Compared to 'lookupPackageName', this function correctly accounts for visibility,
|
| 579 | 587 | -- renaming and thinning.
|
| 580 | -resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
|
|
| 581 | -resolvePackageImport unit_st mn pn = do
|
|
| 588 | +resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
|
|
| 589 | +resolvePackageImport unit_st query mn pn = do
|
|
| 582 | 590 | -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
|
| 583 | - providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
|
|
| 591 | + providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False
|
|
| 584 | 592 | -- 2. Get the UnitIds of the candidates
|
| 585 | 593 | let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
|
| 586 | 594 | -- 3. Get the package names of the candidates
|
| ... | ... | @@ -638,14 +646,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) |
| 638 | 646 | -- 'initUnits' can be called again subsequently after updating the
|
| 639 | 647 | -- 'packageFlags' field of the 'DynFlags', and it will update the
|
| 640 | 648 | -- 'unitState' in 'DynFlags'.
|
| 641 | -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
|
|
| 642 | -initUnits logger dflags cached_dbs home_units = do
|
|
| 649 | +initUnits :: Logger -> DynFlags -> UnitIndex -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
|
|
| 650 | +initUnits logger dflags index cached_dbs home_units = do
|
|
| 643 | 651 | |
| 644 | 652 | let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
|
| 645 | 653 | |
| 646 | 654 | (unit_state,dbs) <- withTiming logger (text "initializing unit database")
|
| 647 | 655 | forceUnitInfoMap
|
| 648 | - $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
|
|
| 656 | + $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
|
|
| 649 | 657 | |
| 650 | 658 | putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
|
| 651 | 659 | FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
|
| ... | ... | @@ -1484,9 +1492,11 @@ validateDatabase cfg pkg_map1 = |
| 1484 | 1492 | |
| 1485 | 1493 | mkUnitState
|
| 1486 | 1494 | :: Logger
|
| 1495 | + -> UnitId
|
|
| 1487 | 1496 | -> UnitConfig
|
| 1497 | + -> UnitIndex
|
|
| 1488 | 1498 | -> IO (UnitState,[UnitDatabase UnitId])
|
| 1489 | -mkUnitState logger cfg = do
|
|
| 1499 | +mkUnitState logger unit cfg index = do
|
|
| 1490 | 1500 | {-
|
| 1491 | 1501 | Plan.
|
| 1492 | 1502 | |
| ... | ... | @@ -1542,15 +1552,9 @@ mkUnitState logger cfg = do |
| 1542 | 1552 | |
| 1543 | 1553 | -- if databases have not been provided, read the database flags
|
| 1544 | 1554 | raw_dbs <- case unitConfigDBCache cfg of
|
| 1545 | - Nothing -> readUnitDatabases logger cfg
|
|
| 1555 | + Nothing -> readDatabases index logger unit cfg
|
|
| 1546 | 1556 | Just dbs -> return dbs
|
| 1547 | 1557 | |
| 1548 | - -- distrust all units if the flag is set
|
|
| 1549 | - let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
|
|
| 1550 | - dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
|
|
| 1551 | - | otherwise = raw_dbs
|
|
| 1552 | - |
|
| 1553 | - |
|
| 1554 | 1558 | -- This, and the other reverse's that you will see, are due to the fact that
|
| 1555 | 1559 | -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
|
| 1556 | 1560 | -- than they are on the command line.
|
| ... | ... | @@ -1562,15 +1566,20 @@ mkUnitState logger cfg = do |
| 1562 | 1566 | let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
|
| 1563 | 1567 | |
| 1564 | 1568 | -- Merge databases together, without checking validity
|
| 1565 | - (pkg_map1, prec_map) <- mergeDatabases logger dbs
|
|
| 1569 | + (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
|
|
| 1566 | 1570 | |
| 1567 | 1571 | -- Now that we've merged everything together, prune out unusable
|
| 1568 | 1572 | -- packages.
|
| 1569 | - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
|
|
| 1573 | + let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
|
|
| 1570 | 1574 | |
| 1571 | 1575 | reportCycles logger sccs
|
| 1572 | 1576 | reportUnusable logger unusable
|
| 1573 | 1577 | |
| 1578 | + -- distrust all units if the flag is set
|
|
| 1579 | + let distrust_all info = info {unitIsTrusted = False}
|
|
| 1580 | + pkg_map2 | unitConfigDistrustAll cfg = distrust_all <$> initial_dbs
|
|
| 1581 | + | otherwise = initial_dbs
|
|
| 1582 | + |
|
| 1574 | 1583 | -- Apply trust flags (these flags apply regardless of whether
|
| 1575 | 1584 | -- or not packages are visible or not)
|
| 1576 | 1585 | pkgs1 <- mayThrowUnitErr
|
| ... | ... | @@ -1675,6 +1684,9 @@ mkUnitState logger cfg = do |
| 1675 | 1684 | -- likely to actually happen.
|
| 1676 | 1685 | return (updateVisibilityMap wired_map plugin_vis_map2)
|
| 1677 | 1686 | |
| 1687 | + (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
|
|
| 1688 | + computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
|
|
| 1689 | + |
|
| 1678 | 1690 | let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
|
| 1679 | 1691 | | p <- pkgs2
|
| 1680 | 1692 | ]
|
| ... | ... | @@ -1687,8 +1699,6 @@ mkUnitState logger cfg = do |
| 1687 | 1699 | req_ctx = mapUniqMap (Set.toList)
|
| 1688 | 1700 | $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
|
| 1689 | 1701 | |
| 1690 | - |
|
| 1691 | - --
|
|
| 1692 | 1702 | -- Here we build up a set of the packages mentioned in -package
|
| 1693 | 1703 | -- flags on the command line; these are called the "preload"
|
| 1694 | 1704 | -- packages. we link these packages in eagerly. The preload set
|
| ... | ... | @@ -1711,10 +1721,6 @@ mkUnitState logger cfg = do |
| 1711 | 1721 | $ closeUnitDeps pkg_db
|
| 1712 | 1722 | $ zip (map toUnitId preload3) (repeat Nothing)
|
| 1713 | 1723 | |
| 1714 | - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
|
|
| 1715 | - mod_map2 = mkUnusableModuleNameProvidersMap unusable
|
|
| 1716 | - mod_map = mod_map2 `plusUniqMap` mod_map1
|
|
| 1717 | - |
|
| 1718 | 1724 | -- Force the result to avoid leaking input parameters
|
| 1719 | 1725 | let !state = UnitState
|
| 1720 | 1726 | { preloadUnits = dep_preload
|
| ... | ... | @@ -1722,8 +1728,8 @@ mkUnitState logger cfg = do |
| 1722 | 1728 | , homeUnitDepends = Set.toList home_unit_deps
|
| 1723 | 1729 | , unitInfoMap = pkg_db
|
| 1724 | 1730 | , preloadClosure = emptyUniqSet
|
| 1725 | - , moduleNameProvidersMap = mod_map
|
|
| 1726 | - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
|
|
| 1731 | + , moduleNameProvidersMap
|
|
| 1732 | + , pluginModuleNameProvidersMap
|
|
| 1727 | 1733 | , packageNameMap = pkgname_map
|
| 1728 | 1734 | , wireMap = wired_map
|
| 1729 | 1735 | , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
|
| ... | ... | @@ -1896,6 +1902,76 @@ addListTo = foldl' merge |
| 1896 | 1902 | mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
|
| 1897 | 1903 | mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
|
| 1898 | 1904 | |
| 1905 | +-- -----------------------------------------------------------------------------
|
|
| 1906 | +-- Index
|
|
| 1907 | + |
|
| 1908 | +data UnitIndexQuery =
|
|
| 1909 | + UnitIndexQuery {
|
|
| 1910 | + findOrigin :: UnitState -> ModuleName -> Bool -> Maybe (UniqMap Module ModuleOrigin),
|
|
| 1911 | + moduleProviders :: UnitState -> ModuleNameProvidersMap
|
|
| 1912 | + }
|
|
| 1913 | + |
|
| 1914 | +data UnitIndex =
|
|
| 1915 | + UnitIndex {
|
|
| 1916 | + unitIndexQuery :: UnitId -> IO UnitIndexQuery,
|
|
| 1917 | + readDatabases :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId],
|
|
| 1918 | + computeProviders ::
|
|
| 1919 | + Logger ->
|
|
| 1920 | + UnitId ->
|
|
| 1921 | + UnitConfig ->
|
|
| 1922 | + VisibilityMap ->
|
|
| 1923 | + VisibilityMap ->
|
|
| 1924 | + UnitInfoMap ->
|
|
| 1925 | + UnitInfoMap ->
|
|
| 1926 | + ModuleNameProvidersMap ->
|
|
| 1927 | + IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
|
|
| 1928 | + }
|
|
| 1929 | + |
|
| 1930 | +queryFindOriginDefault ::
|
|
| 1931 | + UnitState ->
|
|
| 1932 | + ModuleName ->
|
|
| 1933 | + Bool ->
|
|
| 1934 | + Maybe (UniqMap Module ModuleOrigin)
|
|
| 1935 | +queryFindOriginDefault UnitState {moduleNameProvidersMap, pluginModuleNameProvidersMap} name plugins =
|
|
| 1936 | + lookupUniqMap source name
|
|
| 1937 | + where
|
|
| 1938 | + source = if plugins then pluginModuleNameProvidersMap else moduleNameProvidersMap
|
|
| 1939 | + |
|
| 1940 | +newUnitIndexQuery :: UnitId -> IO UnitIndexQuery
|
|
| 1941 | +newUnitIndexQuery _ =
|
|
| 1942 | + pure UnitIndexQuery {
|
|
| 1943 | + findOrigin = queryFindOriginDefault,
|
|
| 1944 | + moduleProviders = moduleNameProvidersMap
|
|
| 1945 | + }
|
|
| 1946 | + |
|
| 1947 | +readDatabasesDefault :: Logger -> UnitId -> UnitConfig -> IO [UnitDatabase UnitId]
|
|
| 1948 | +readDatabasesDefault logger _ cfg =
|
|
| 1949 | + readUnitDatabases logger cfg
|
|
| 1950 | + |
|
| 1951 | +computeProvidersDefault ::
|
|
| 1952 | + Logger ->
|
|
| 1953 | + UnitId ->
|
|
| 1954 | + UnitConfig ->
|
|
| 1955 | + VisibilityMap ->
|
|
| 1956 | + VisibilityMap ->
|
|
| 1957 | + UnitInfoMap ->
|
|
| 1958 | + UnitInfoMap ->
|
|
| 1959 | + ModuleNameProvidersMap ->
|
|
| 1960 | + IO (ModuleNameProvidersMap, ModuleNameProvidersMap)
|
|
| 1961 | +computeProvidersDefault logger _ cfg vis_map plugin_vis_map _initial_dbs pkg_db unusable =
|
|
| 1962 | + pure (mod_map, plugin_mod_map)
|
|
| 1963 | + where
|
|
| 1964 | + mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
|
|
| 1965 | + mod_map = unusable `plusUniqMap` mod_map1
|
|
| 1966 | + plugin_mod_map = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
|
|
| 1967 | + |
|
| 1968 | +newUnitIndex :: IO UnitIndex
|
|
| 1969 | +newUnitIndex =
|
|
| 1970 | + pure UnitIndex {
|
|
| 1971 | + unitIndexQuery = newUnitIndexQuery,
|
|
| 1972 | + readDatabases = readDatabasesDefault,
|
|
| 1973 | + computeProviders = computeProvidersDefault
|
|
| 1974 | + }
|
|
| 1899 | 1975 | |
| 1900 | 1976 | -- -----------------------------------------------------------------------------
|
| 1901 | 1977 | -- Package Utils
|
| ... | ... | @@ -1903,10 +1979,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod) |
| 1903 | 1979 | -- | Takes a 'ModuleName', and if the module is in any package returns
|
| 1904 | 1980 | -- list of modules which take that name.
|
| 1905 | 1981 | lookupModuleInAllUnits :: UnitState
|
| 1982 | + -> UnitIndexQuery
|
|
| 1906 | 1983 | -> ModuleName
|
| 1907 | 1984 | -> [(Module, UnitInfo)]
|
| 1908 | -lookupModuleInAllUnits pkgs m
|
|
| 1909 | - = case lookupModuleWithSuggestions pkgs m NoPkgQual of
|
|
| 1985 | +lookupModuleInAllUnits pkgs query m
|
|
| 1986 | + = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
|
|
| 1910 | 1987 | LookupFound a b -> [(a,fst b)]
|
| 1911 | 1988 | LookupMultiple rs -> map f rs
|
| 1912 | 1989 | where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
|
| ... | ... | @@ -1933,18 +2010,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin |
| 1933 | 2010 | | SuggestHidden ModuleName Module ModuleOrigin
|
| 1934 | 2011 | |
| 1935 | 2012 | lookupModuleWithSuggestions :: UnitState
|
| 2013 | + -> UnitIndexQuery
|
|
| 1936 | 2014 | -> ModuleName
|
| 1937 | 2015 | -> PkgQual
|
| 1938 | 2016 | -> LookupResult
|
| 1939 | -lookupModuleWithSuggestions pkgs
|
|
| 1940 | - = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
|
|
| 2017 | +lookupModuleWithSuggestions pkgs query name
|
|
| 2018 | + = lookupModuleWithSuggestions' pkgs query name False
|
|
| 1941 | 2019 | |
| 1942 | 2020 | -- | The package which the module **appears** to come from, this could be
|
| 1943 | 2021 | -- the one which reexports the module from it's original package. This function
|
| 1944 | 2022 | -- is currently only used for -Wunused-packages
|
| 1945 | -lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
|
|
| 1946 | -lookupModulePackage pkgs mn mfs =
|
|
| 1947 | - case lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs) mn mfs of
|
|
| 2023 | +lookupModulePackage ::
|
|
| 2024 | + UnitState ->
|
|
| 2025 | + UnitIndexQuery ->
|
|
| 2026 | + ModuleName ->
|
|
| 2027 | + PkgQual ->
|
|
| 2028 | + Maybe [UnitInfo]
|
|
| 2029 | +lookupModulePackage pkgs query mn mfs =
|
|
| 2030 | + case lookupModuleWithSuggestions' pkgs query mn False mfs of
|
|
| 1948 | 2031 | LookupFound _ (orig_unit, origin) ->
|
| 1949 | 2032 | case origin of
|
| 1950 | 2033 | ModOrigin {fromOrigUnit, fromExposedReexport} ->
|
| ... | ... | @@ -1960,19 +2043,21 @@ lookupModulePackage pkgs mn mfs = |
| 1960 | 2043 | _ -> Nothing
|
| 1961 | 2044 | |
| 1962 | 2045 | lookupPluginModuleWithSuggestions :: UnitState
|
| 2046 | + -> UnitIndexQuery
|
|
| 1963 | 2047 | -> ModuleName
|
| 1964 | 2048 | -> PkgQual
|
| 1965 | 2049 | -> LookupResult
|
| 1966 | -lookupPluginModuleWithSuggestions pkgs
|
|
| 1967 | - = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
|
|
| 2050 | +lookupPluginModuleWithSuggestions pkgs query name
|
|
| 2051 | + = lookupModuleWithSuggestions' pkgs query name True
|
|
| 1968 | 2052 | |
| 1969 | 2053 | lookupModuleWithSuggestions' :: UnitState
|
| 1970 | - -> ModuleNameProvidersMap
|
|
| 2054 | + -> UnitIndexQuery
|
|
| 1971 | 2055 | -> ModuleName
|
| 2056 | + -> Bool
|
|
| 1972 | 2057 | -> PkgQual
|
| 1973 | 2058 | -> LookupResult
|
| 1974 | -lookupModuleWithSuggestions' pkgs mod_map m mb_pn
|
|
| 1975 | - = case lookupUniqMap mod_map m of
|
|
| 2059 | +lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
|
|
| 2060 | + = case findOrigin query pkgs m onlyPlugins of
|
|
| 1976 | 2061 | Nothing -> LookupNotFound suggestions
|
| 1977 | 2062 | Just xs ->
|
| 1978 | 2063 | case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
|
| ... | ... | @@ -2033,16 +2118,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn |
| 2033 | 2118 | all_mods :: [(String, ModuleSuggestion)] -- All modules
|
| 2034 | 2119 | all_mods = sortBy (comparing fst) $
|
| 2035 | 2120 | [ (moduleNameString m, suggestion)
|
| 2036 | - | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
|
|
| 2121 | + | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs)
|
|
| 2037 | 2122 | , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
|
| 2038 | 2123 | ]
|
| 2039 | 2124 | getSuggestion name (mod, origin) =
|
| 2040 | 2125 | (if originVisible origin then SuggestVisible else SuggestHidden)
|
| 2041 | 2126 | name mod origin
|
| 2042 | 2127 | |
| 2043 | -listVisibleModuleNames :: UnitState -> [ModuleName]
|
|
| 2044 | -listVisibleModuleNames state =
|
|
| 2045 | - map fst (filter visible (nonDetUniqMapToList (moduleNameProvidersMap state)))
|
|
| 2128 | +listVisibleModuleNames :: UnitState -> UnitIndexQuery -> [ModuleName]
|
|
| 2129 | +listVisibleModuleNames unit_state query =
|
|
| 2130 | + map fst (filter visible (nonDetUniqMapToList (moduleProviders query unit_state)))
|
|
| 2046 | 2131 | where visible (_, ms) = anyUniqMap originVisible ms
|
| 2047 | 2132 | |
| 2048 | 2133 | -- | Takes a list of UnitIds (and their "parent" dependency, used for error
|
| ... | ... | @@ -3695,19 +3695,21 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 |
| 3695 | 3695 | |
| 3696 | 3696 | completeModule = wrapIdentCompleterMod $ \w -> do
|
| 3697 | 3697 | hsc_env <- GHC.getSession
|
| 3698 | - let pkg_mods = allVisibleModules (hsc_units hsc_env)
|
|
| 3698 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 3699 | + let pkg_mods = allVisibleModules (hsc_units hsc_env) query
|
|
| 3699 | 3700 | loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
|
| 3700 | 3701 | return $ filter (w `isPrefixOf`)
|
| 3701 | 3702 | $ map (showPpr (hsc_dflags hsc_env)) $ loaded_mods ++ pkg_mods
|
| 3702 | 3703 | |
| 3703 | 3704 | completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do
|
| 3704 | 3705 | hsc_env <- GHC.getSession
|
| 3706 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 3705 | 3707 | modules <- case m of
|
| 3706 | 3708 | Just '-' -> do
|
| 3707 | 3709 | imports <- GHC.getContext
|
| 3708 | 3710 | return $ map iiModuleName imports
|
| 3709 | 3711 | _ -> do
|
| 3710 | - let pkg_mods = allVisibleModules (hsc_units hsc_env)
|
|
| 3712 | + let pkg_mods = allVisibleModules (hsc_units hsc_env) query
|
|
| 3711 | 3713 | loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules
|
| 3712 | 3714 | return $ loaded_mods ++ pkg_mods
|
| 3713 | 3715 | return $ filter (w `isPrefixOf`) $ map (showPpr (hsc_dflags hsc_env)) modules
|
| ... | ... | @@ -3775,8 +3777,8 @@ wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing wor |
| 3775 | 3777 | |
| 3776 | 3778 | -- | Return a list of visible module names for autocompletion.
|
| 3777 | 3779 | -- (NB: exposed != visible)
|
| 3778 | -allVisibleModules :: UnitState -> [ModuleName]
|
|
| 3779 | -allVisibleModules unit_state = listVisibleModuleNames unit_state
|
|
| 3780 | +allVisibleModules :: UnitState -> UnitIndexQuery -> [ModuleName]
|
|
| 3781 | +allVisibleModules us query = listVisibleModuleNames us query
|
|
| 3780 | 3782 | |
| 3781 | 3783 | completeExpression = completeQuotedWord (Just '\\') "\"" listFiles
|
| 3782 | 3784 | completeIdentifier
|
| ... | ... | @@ -374,10 +374,11 @@ printForUserGlobalRdrEnv mb_rdr_env doc = do |
| 374 | 374 | where
|
| 375 | 375 | mkNamePprCtxFromGlobalRdrEnv _ Nothing = GHC.getNamePprCtx
|
| 376 | 376 | mkNamePprCtxFromGlobalRdrEnv dflags (Just rdr_env) =
|
| 377 | - withSession $ \ hsc_env ->
|
|
| 377 | + withSession $ \ hsc_env -> do
|
|
| 378 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 378 | 379 | let unit_env = hsc_unit_env hsc_env
|
| 379 | 380 | ptc = initPromotionTickContext dflags
|
| 380 | - in return $ Ppr.mkNamePprCtx ptc unit_env rdr_env
|
|
| 381 | + return $ Ppr.mkNamePprCtx ptc unit_env query rdr_env
|
|
| 381 | 382 | |
| 382 | 383 | printForUser :: GhcMonad m => SDoc -> m ()
|
| 383 | 384 | printForUser doc = do
|
| ... | ... | @@ -839,12 +839,13 @@ initMulti unitArgsFiles = do |
| 839 | 839 | |
| 840 | 840 | let (initial_home_graph, mainUnitId) = createUnitEnvFromFlags unitDflags
|
| 841 | 841 | home_units = unitEnv_keys initial_home_graph
|
| 842 | + ue_index = hscUnitIndex hsc_env
|
|
| 842 | 843 | |
| 843 | 844 | home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do
|
| 844 | 845 | let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv
|
| 845 | 846 | hue_flags = homeUnitEnv_dflags homeUnitEnv
|
| 846 | 847 | dflags = homeUnitEnv_dflags homeUnitEnv
|
| 847 | - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units
|
|
| 848 | + (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags ue_index cached_unit_dbs home_units
|
|
| 848 | 849 | |
| 849 | 850 | updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants
|
| 850 | 851 | pure $ HomeUnitEnv
|
| ... | ... | @@ -859,7 +860,7 @@ initMulti unitArgsFiles = do |
| 859 | 860 | |
| 860 | 861 | let dflags = homeUnitEnv_dflags $ unitEnv_lookup mainUnitId home_unit_graph
|
| 861 | 862 | unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))
|
| 862 | - let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }
|
|
| 863 | + let final_hsc_env = hsc_env { hsc_unit_env = unitEnv {ue_index} }
|
|
| 863 | 864 | |
| 864 | 865 | GHC.setSession final_hsc_env
|
| 865 | 866 |