Torsten Schmits pushed to branch wip/torsten.schmits/unit-index-mwb at Glasgow Haskell Compiler / GHC
Commits:
-
91d83309
by Torsten Schmits at 2025-12-11T19:30:11+01:00
-
757dcdf0
by Georgios Karachalias at 2025-12-11T19:30:11+01:00
-
958351f6
by Torsten Schmits at 2025-12-11T19:30:11+01:00
-
fd6ab2f7
by Torsten Schmits at 2025-12-11T19:30:11+01:00
-
2fcf61c0
by Torsten Schmits at 2025-12-11T19:30:11+01:00
27 changed files:
- compiler/GHC.hs
- compiler/GHC/Core/Opt/Pipeline.hs
- + compiler/GHC/Data/OsPath.hs
- compiler/GHC/Driver/Backpack.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Env.hs
- compiler/GHC/Driver/Main.hs
- compiler/GHC/Driver/Make.hs
- compiler/GHC/Driver/Pipeline/Execute.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/Iface/Recomp.hs
- compiler/GHC/Linker/Deps.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
- compiler/ghc.cabal.in
- 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 |
| 1 | +module GHC.Data.OsPath
|
|
| 2 | + (
|
|
| 3 | + -- * OsPath initialisation and transformation
|
|
| 4 | + OsPath
|
|
| 5 | + , OsString
|
|
| 6 | + , encodeUtf
|
|
| 7 | + , decodeUtf
|
|
| 8 | + , unsafeDecodeUtf
|
|
| 9 | + , unsafeEncodeUtf
|
|
| 10 | + , os
|
|
| 11 | + -- * Common utility functions
|
|
| 12 | + , (</>)
|
|
| 13 | + , (<.>)
|
|
| 14 | + , splitSearchPath
|
|
| 15 | + , isRelative
|
|
| 16 | + , dropTrailingPathSeparator
|
|
| 17 | + , takeDirectory
|
|
| 18 | + , isSuffixOf
|
|
| 19 | + , doesDirectoryExist
|
|
| 20 | + , doesFileExist
|
|
| 21 | + , getDirectoryContents
|
|
| 22 | + , createDirectoryIfMissing
|
|
| 23 | + , pprOsPath
|
|
| 24 | + )
|
|
| 25 | + where
|
|
| 26 | + |
|
| 27 | +import GHC.Prelude
|
|
| 28 | + |
|
| 29 | +import GHC.Utils.Misc (HasCallStack)
|
|
| 30 | +import GHC.Utils.Outputable qualified as Outputable
|
|
| 31 | +import GHC.Utils.Panic (panic)
|
|
| 32 | + |
|
| 33 | +import System.OsPath
|
|
| 34 | +import System.OsString (isSuffixOf)
|
|
| 35 | +import System.Directory.OsPath (doesDirectoryExist, doesFileExist, getDirectoryContents, createDirectoryIfMissing)
|
|
| 36 | +import System.Directory.Internal (os)
|
|
| 37 | + |
|
| 38 | +-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.
|
|
| 39 | +-- Prefer 'decodeUtf' and gracious error handling.
|
|
| 40 | +unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath
|
|
| 41 | +unsafeDecodeUtf p =
|
|
| 42 | + either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
|
|
| 43 | + |
|
| 44 | +pprOsPath :: HasCallStack => OsPath -> Outputable.SDoc
|
|
| 45 | +pprOsPath = Outputable.text . unsafeDecodeUtf |
| ... | ... | @@ -76,6 +76,7 @@ import qualified GHC.LanguageExtensions as LangExt |
| 76 | 76 | import GHC.Data.Maybe
|
| 77 | 77 | import GHC.Data.StringBuffer
|
| 78 | 78 | import GHC.Data.FastString
|
| 79 | +import qualified GHC.Data.OsPath as OsPath
|
|
| 79 | 80 | import qualified GHC.Data.EnumSet as EnumSet
|
| 80 | 81 | import qualified GHC.Data.ShortText as ST
|
| 81 | 82 | |
| ... | ... | @@ -429,15 +430,16 @@ addUnit u = do |
| 429 | 430 | logger <- getLogger
|
| 430 | 431 | let dflags0 = hsc_dflags hsc_env
|
| 431 | 432 | let old_unit_env = hsc_unit_env hsc_env
|
| 433 | + ue_index = hscUnitIndex hsc_env
|
|
| 432 | 434 | newdbs <- case ue_unit_dbs old_unit_env of
|
| 433 | 435 | Nothing -> panic "addUnit: called too early"
|
| 434 | 436 | Just dbs ->
|
| 435 | 437 | let newdb = UnitDatabase
|
| 436 | - { unitDatabasePath = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
|
|
| 438 | + { unitDatabasePath = OsPath.unsafeEncodeUtf $ "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"
|
|
| 437 | 439 | , unitDatabaseUnits = [u]
|
| 438 | 440 | }
|
| 439 | 441 | 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)
|
|
| 442 | + (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 ue_index (Just newdbs) (hsc_all_home_unit_ids hsc_env)
|
|
| 441 | 443 | |
| 442 | 444 | -- update platform constants
|
| 443 | 445 | dflags <- liftIO $ updatePlatformConstants dflags0 mconstants
|
| ... | ... | @@ -452,6 +454,7 @@ addUnit u = do |
| 452 | 454 | (homeUnitId home_unit)
|
| 453 | 455 | (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just home_unit))
|
| 454 | 456 | , ue_eps = ue_eps old_unit_env
|
| 457 | + , ue_index
|
|
| 455 | 458 | }
|
| 456 | 459 | setSession $ hscSetFlags dflags $ hsc_env { hsc_unit_env = unit_env }
|
| 457 | 460 | |
| ... | ... | @@ -870,6 +873,8 @@ hsModuleToModSummary home_keys pn hsc_src modname |
| 870 | 873 | hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
|
| 871 | 874 | hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
|
| 872 | 875 | |
| 876 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 877 | + |
|
| 873 | 878 | -- Also copied from 'getImports'
|
| 874 | 879 | let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps
|
| 875 | 880 | |
| ... | ... | @@ -882,7 +887,7 @@ hsModuleToModSummary home_keys pn hsc_src modname |
| 882 | 887 | implicit_imports = mkPrelImports modname loc
|
| 883 | 888 | implicit_prelude imps
|
| 884 | 889 | |
| 885 | - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname
|
|
| 890 | + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query modname
|
|
| 886 | 891 | convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)
|
| 887 | 892 | |
| 888 | 893 | extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname
|
| ... | ... | @@ -96,6 +96,7 @@ import GHC.Core.Unfold |
| 96 | 96 | import GHC.Data.Bool
|
| 97 | 97 | import GHC.Data.EnumSet (EnumSet)
|
| 98 | 98 | import GHC.Data.Maybe
|
| 99 | +import GHC.Data.OsPath (OsPath)
|
|
| 99 | 100 | import GHC.Builtin.Names ( mAIN_NAME )
|
| 100 | 101 | import GHC.Driver.Backend
|
| 101 | 102 | import GHC.Driver.Flags
|
| ... | ... | @@ -948,7 +949,7 @@ setDynamicNow dflags0 = |
| 948 | 949 | data PkgDbRef
|
| 949 | 950 | = GlobalPkgDb
|
| 950 | 951 | | UserPkgDb
|
| 951 | - | PkgDbPath FilePath
|
|
| 952 | + | PkgDbPath OsPath
|
|
| 952 | 953 | deriving Eq
|
| 953 | 954 | |
| 954 | 955 | -- | Used to differentiate the scope an include needs to apply to.
|
| ... | ... | @@ -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 |
| ... | ... | @@ -1009,11 +1009,6 @@ initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = do |
| 1009 | 1009 | types_var <- newIORef (md_types details)
|
| 1010 | 1010 | let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])
|
| 1011 | 1011 | let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }
|
| 1012 | - core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi
|
|
| 1013 | - -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do
|
|
| 1014 | - -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone
|
|
| 1015 | - -- reports a bug.
|
|
| 1016 | - let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []
|
|
| 1017 | 1012 | -- The bytecode generation itself is lazy because otherwise even when doing
|
| 1018 | 1013 | -- recompilation checking the bytecode will be generated (which slows things down a lot)
|
| 1019 | 1014 | -- the laziness is OK because generateByteCode just depends on things already loaded
|
| ... | ... | @@ -2578,9 +2573,10 @@ hscTidy hsc_env guts = do |
| 2578 | 2573 | $! {-# SCC "CoreTidy" #-} tidyProgram opts guts
|
| 2579 | 2574 | |
| 2580 | 2575 | -- post tidy pretty-printing and linting...
|
| 2576 | + query <- hscUnitIndexQuery hsc_env
|
|
| 2581 | 2577 | let tidy_rules = md_rules details
|
| 2582 | 2578 | let all_tidy_binds = cg_binds cgguts
|
| 2583 | - let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)
|
|
| 2579 | + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) query (mg_rdr_env guts)
|
|
| 2584 | 2580 | ptc = initPromotionTickContext (hsc_dflags hsc_env)
|
| 2585 | 2581 | |
| 2586 | 2582 | endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules
|
| ... | ... | @@ -187,12 +187,13 @@ depanalE excluded_mods allow_dup_roots = do |
| 187 | 187 | if isEmptyMessages errs
|
| 188 | 188 | then do
|
| 189 | 189 | hsc_env <- getSession
|
| 190 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 190 | 191 | let one_unit_messages get_mod_errs k hue = do
|
| 191 | 192 | errs <- get_mod_errs
|
| 192 | 193 | unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph
|
| 193 | 194 | |
| 194 | 195 | let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph
|
| 195 | - unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph
|
|
| 196 | + unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) query (homeUnitEnv_dflags hue) mod_graph
|
|
| 196 | 197 | |
| 197 | 198 | |
| 198 | 199 | return $ errs `unionMessages` unused_home_mod_err
|
| ... | ... | @@ -510,15 +511,15 @@ loadWithCache cache diag_wrapper how_much = do |
| 510 | 511 | -- actually loaded packages. All the packages, specified on command line,
|
| 511 | 512 | -- but never loaded, are probably unused dependencies.
|
| 512 | 513 | |
| 513 | -warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages
|
|
| 514 | -warnUnusedPackages us dflags mod_graph =
|
|
| 514 | +warnUnusedPackages :: UnitState -> UnitIndexQuery -> DynFlags -> ModuleGraph -> DriverMessages
|
|
| 515 | +warnUnusedPackages us query dflags mod_graph =
|
|
| 515 | 516 | let diag_opts = initDiagOpts dflags
|
| 516 | 517 | |
| 517 | 518 | home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)
|
| 518 | 519 | |
| 519 | 520 | -- Only need non-source imports here because SOURCE imports are always HPT
|
| 520 | 521 | loadedPackages = concat $
|
| 521 | - mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)
|
|
| 522 | + mapMaybe (\(fs, mn) -> lookupModulePackage us query (unLoc mn) fs)
|
|
| 522 | 523 | $ concatMap ms_imps home_mod_sum
|
| 523 | 524 | |
| 524 | 525 | any_import_ghc_prim = any ms_ghc_prim_import home_mod_sum
|
| ... | ... | @@ -2384,7 +2385,8 @@ getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do |
| 2384 | 2385 | mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn
|
| 2385 | 2386 | let mopts = map unLoc $ snd $ getOptions popts pi_hspp_buf src_fn
|
| 2386 | 2387 | pure $ ((, mopts) <$>) $ first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps
|
| 2387 | - let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
|
|
| 2388 | + query <- liftIO $ hscUnitIndexQuery hsc_env
|
|
| 2389 | + let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
|
|
| 2388 | 2390 | let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))
|
| 2389 | 2391 | let pi_srcimps = rn_imps pi_srcimps'
|
| 2390 | 2392 | let pi_theimps = rn_imps pi_theimps'
|
| ... | ... | @@ -696,9 +696,10 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do |
| 696 | 696 | -- gather the imports and module name
|
| 697 | 697 | (hspp_buf,mod_name,imps,src_imps, ghc_prim_imp) <- do
|
| 698 | 698 | buf <- hGetStringBuffer input_fn
|
| 699 | + query <- hscUnitIndexQuery hsc_env
|
|
| 699 | 700 | let imp_prelude = xopt LangExt.ImplicitPrelude dflags
|
| 700 | 701 | popts = initParserOpts dflags
|
| 701 | - rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)
|
|
| 702 | + rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) query
|
|
| 702 | 703 | rn_imps = fmap (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))
|
| 703 | 704 | eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)
|
| 704 | 705 | case eimps of
|
| ... | ... | @@ -255,6 +255,7 @@ import GHC.Types.SrcLoc |
| 255 | 255 | import GHC.Types.SafeHaskell
|
| 256 | 256 | import GHC.Types.Basic ( treatZeroAsInf )
|
| 257 | 257 | import GHC.Data.FastString
|
| 258 | +import qualified GHC.Data.OsPath as OsPath
|
|
| 258 | 259 | import GHC.Utils.TmpFs
|
| 259 | 260 | import GHC.Utils.Fingerprint
|
| 260 | 261 | import GHC.Utils.Outputable
|
| ... | ... | @@ -1962,7 +1963,7 @@ package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))] |
| 1962 | 1963 | package_flags_deps = [
|
| 1963 | 1964 | ------- Packages ----------------------------------------------------
|
| 1964 | 1965 | make_ord_flag defFlag "package-db"
|
| 1965 | - (HasArg (addPkgDbRef . PkgDbPath))
|
|
| 1966 | + (HasArg (addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf))
|
|
| 1966 | 1967 | , make_ord_flag defFlag "clear-package-db" (NoArg clearPkgDb)
|
| 1967 | 1968 | , make_ord_flag defFlag "no-global-package-db" (NoArg removeGlobalPkgDb)
|
| 1968 | 1969 | , make_ord_flag defFlag "no-user-package-db" (NoArg removeUserPkgDb)
|
| ... | ... | @@ -1972,7 +1973,7 @@ package_flags_deps = [ |
| 1972 | 1973 | (NoArg (addPkgDbRef UserPkgDb))
|
| 1973 | 1974 | -- backwards compat with GHC<=7.4 :
|
| 1974 | 1975 | , make_dep_flag defFlag "package-conf"
|
| 1975 | - (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"
|
|
| 1976 | + (HasArg $ addPkgDbRef . PkgDbPath . OsPath.unsafeEncodeUtf) "Use -package-db instead"
|
|
| 1976 | 1977 | , make_dep_flag defFlag "no-user-package-conf"
|
| 1977 | 1978 | (NoArg removeUserPkgDb) "Use -no-user-package-db instead"
|
| 1978 | 1979 | , make_ord_flag defGhcFlag "package-name" (HasArg $ \name ->
|
| ... | ... | @@ -3377,7 +3378,7 @@ parseEnvFile :: FilePath -> String -> DynP () |
| 3377 | 3378 | parseEnvFile envfile = mapM_ parseEntry . lines
|
| 3378 | 3379 | where
|
| 3379 | 3380 | parseEntry str = case words str of
|
| 3380 | - ("package-db": _) -> addPkgDbRef (PkgDbPath (envdir </> db))
|
|
| 3381 | + ("package-db": _) -> addPkgDbRef (PkgDbPath (OsPath.unsafeEncodeUtf (envdir </> db)))
|
|
| 3381 | 3382 | -- relative package dbs are interpreted relative to the env file
|
| 3382 | 3383 | where envdir = takeDirectory envfile
|
| 3383 | 3384 | db = drop 11 str
|
| ... | ... | @@ -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
|
| ... | ... | @@ -53,8 +53,6 @@ import Control.Monad.IO.Class (MonadIO (liftIO)) |
| 53 | 53 | import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
|
| 54 | 54 | |
| 55 | 55 | import qualified Data.Set as Set
|
| 56 | -import qualified Data.Map as M
|
|
| 57 | -import Data.List (isSuffixOf)
|
|
| 58 | 56 | |
| 59 | 57 | import System.FilePath
|
| 60 | 58 | import System.Directory
|
| ... | ... | @@ -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 | |
| ... | ... | @@ -161,17 +161,19 @@ findImportedModule hsc_env mod pkg_qual = |
| 161 | 161 | dflags = hsc_dflags hsc_env
|
| 162 | 162 | fopts = initFinderOpts dflags
|
| 163 | 163 | in do
|
| 164 | - findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) mhome_unit mod pkg_qual
|
|
| 164 | + query <- hscUnitIndexQuery hsc_env
|
|
| 165 | + findImportedModuleNoHsc fc fopts (hsc_unit_env hsc_env) query mhome_unit mod pkg_qual
|
|
| 165 | 166 | |
| 166 | 167 | findImportedModuleNoHsc
|
| 167 | 168 | :: FinderCache
|
| 168 | 169 | -> FinderOpts
|
| 169 | 170 | -> UnitEnv
|
| 171 | + -> UnitIndexQuery
|
|
| 170 | 172 | -> Maybe HomeUnit
|
| 171 | 173 | -> ModuleName
|
| 172 | 174 | -> PkgQual
|
| 173 | 175 | -> IO FindResult
|
| 174 | -findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg =
|
|
| 176 | +findImportedModuleNoHsc fc fopts ue query mhome_unit mod_name mb_pkg =
|
|
| 175 | 177 | case mb_pkg of
|
| 176 | 178 | NoPkgQual -> unqual_import
|
| 177 | 179 | ThisPkg uid | (homeUnitId <$> mhome_unit) == Just uid -> home_import
|
| ... | ... | @@ -193,7 +195,7 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = |
| 193 | 195 | -- If the module is reexported, then look for it as if it was from the perspective
|
| 194 | 196 | -- of that package which reexports it.
|
| 195 | 197 | | mod_name `Set.member` finder_reexportedModules opts =
|
| 196 | - findImportedModuleNoHsc fc opts ue (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
|
|
| 198 | + findImportedModuleNoHsc fc opts ue query (Just $ DefiniteHomeUnit uid Nothing) mod_name NoPkgQual
|
|
| 197 | 199 | | mod_name `Set.member` finder_hiddenModules opts =
|
| 198 | 200 | return (mkHomeHidden uid)
|
| 199 | 201 | | otherwise =
|
| ... | ... | @@ -204,11 +206,11 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = |
| 204 | 206 | -- first before looking at the packages in order.
|
| 205 | 207 | any_home_import = foldr1 orIfNotFound (home_import: map home_pkg_import other_fopts)
|
| 206 | 208 | |
| 207 | - pkg_import = findExposedPackageModule fc fopts units mod_name mb_pkg
|
|
| 209 | + pkg_import = findExposedPackageModule fc fopts units query mod_name mb_pkg
|
|
| 208 | 210 | |
| 209 | 211 | unqual_import = any_home_import
|
| 210 | 212 | `orIfNotFound`
|
| 211 | - findExposedPackageModule fc fopts units mod_name NoPkgQual
|
|
| 213 | + findExposedPackageModule fc fopts units query mod_name NoPkgQual
|
|
| 212 | 214 | |
| 213 | 215 | units = case mhome_unit of
|
| 214 | 216 | Nothing -> ue_units ue
|
| ... | ... | @@ -221,13 +223,13 @@ findImportedModuleNoHsc fc fopts ue mhome_unit mod_name mb_pkg = |
| 221 | 223 | -- plugin. This consults the same set of exposed packages as
|
| 222 | 224 | -- 'findImportedModule', unless @-hide-all-plugin-packages@ or
|
| 223 | 225 | -- @-plugin-package@ are specified.
|
| 224 | -findPluginModule :: FinderCache -> FinderOpts -> UnitState -> Maybe HomeUnit -> ModuleName -> IO FindResult
|
|
| 225 | -findPluginModule fc fopts units (Just home_unit) mod_name =
|
|
| 226 | +findPluginModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> Maybe HomeUnit -> ModuleName -> IO FindResult
|
|
| 227 | +findPluginModule fc fopts units query (Just home_unit) mod_name =
|
|
| 226 | 228 | findHomeModule fc fopts home_unit mod_name
|
| 227 | 229 | `orIfNotFound`
|
| 228 | - findExposedPluginPackageModule fc fopts units mod_name
|
|
| 229 | -findPluginModule fc fopts units Nothing mod_name =
|
|
| 230 | - findExposedPluginPackageModule fc fopts units mod_name
|
|
| 230 | + findExposedPluginPackageModule fc fopts units query mod_name
|
|
| 231 | +findPluginModule fc fopts units query Nothing mod_name =
|
|
| 232 | + findExposedPluginPackageModule fc fopts units query mod_name
|
|
| 231 | 233 | |
| 232 | 234 | -- | Locate a specific 'Module'. The purpose of this function is to
|
| 233 | 235 | -- create a 'ModLocation' for a given 'Module', that is to find out
|
| ... | ... | @@ -283,15 +285,15 @@ homeSearchCache fc home_unit mod_name do_this = do |
| 283 | 285 | let mod = mkModule home_unit mod_name
|
| 284 | 286 | modLocationCache fc mod do_this
|
| 285 | 287 | |
| 286 | -findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult
|
|
| 287 | -findExposedPackageModule fc fopts units mod_name mb_pkg =
|
|
| 288 | +findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> PkgQual -> IO FindResult
|
|
| 289 | +findExposedPackageModule fc fopts units query mod_name mb_pkg =
|
|
| 288 | 290 | findLookupResult fc fopts
|
| 289 | - $ lookupModuleWithSuggestions units mod_name mb_pkg
|
|
| 291 | + $ lookupModuleWithSuggestions units query mod_name mb_pkg
|
|
| 290 | 292 | |
| 291 | -findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult
|
|
| 292 | -findExposedPluginPackageModule fc fopts units mod_name =
|
|
| 293 | +findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> UnitIndexQuery -> ModuleName -> IO FindResult
|
|
| 294 | +findExposedPluginPackageModule fc fopts units query mod_name =
|
|
| 293 | 295 | findLookupResult fc fopts
|
| 294 | - $ lookupPluginModuleWithSuggestions units mod_name NoPkgQual
|
|
| 296 | + $ lookupPluginModuleWithSuggestions units query mod_name NoPkgQual
|
|
| 295 | 297 | |
| 296 | 298 | findLookupResult :: FinderCache -> FinderOpts -> LookupResult -> IO FindResult
|
| 297 | 299 | 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,
|
| ... | ... | @@ -103,6 +111,8 @@ import GHC.Data.Maybe |
| 103 | 111 | import System.Environment ( getEnv )
|
| 104 | 112 | import GHC.Data.FastString
|
| 105 | 113 | import qualified GHC.Data.ShortText as ST
|
| 114 | +import GHC.Data.OsPath (OsPath)
|
|
| 115 | +import qualified GHC.Data.OsPath as OsPath
|
|
| 106 | 116 | import GHC.Utils.Logger
|
| 107 | 117 | import GHC.Utils.Error
|
| 108 | 118 | import GHC.Utils.Exception
|
| ... | ... | @@ -112,7 +122,7 @@ import System.FilePath as FilePath |
| 112 | 122 | import Control.Monad
|
| 113 | 123 | import Data.Graph (stronglyConnComp, SCC(..))
|
| 114 | 124 | import Data.Char ( toUpper )
|
| 115 | -import Data.List ( intersperse, partition, sortBy, isSuffixOf, sortOn )
|
|
| 125 | +import Data.List ( intersperse, partition, sortBy, sortOn )
|
|
| 116 | 126 | import Data.Set (Set)
|
| 117 | 127 | import Data.Monoid (First(..))
|
| 118 | 128 | import qualified Data.Semigroup as Semigroup
|
| ... | ... | @@ -216,7 +226,7 @@ instance Outputable ModuleOrigin where |
| 216 | 226 | (if null rhs
|
| 217 | 227 | then []
|
| 218 | 228 | else [text "hidden reexport by" <+>
|
| 219 | - sep (map (ppr . mkUnit) res)]) ++
|
|
| 229 | + sep (map (ppr . mkUnit) rhs)]) ++
|
|
| 220 | 230 | (if f then [text "package flag"] else [])
|
| 221 | 231 | ))
|
| 222 | 232 | |
| ... | ... | @@ -405,7 +415,7 @@ initUnitConfig dflags cached_dbs home_units = |
| 405 | 415 | |
| 406 | 416 | where
|
| 407 | 417 | offsetPackageDb :: Maybe FilePath -> PackageDBFlag -> PackageDBFlag
|
| 408 | - offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | isRelative p = PackageDB (PkgDbPath (offset </> p))
|
|
| 418 | + offsetPackageDb (Just offset) (PackageDB (PkgDbPath p)) | OsPath.isRelative p = PackageDB (PkgDbPath (OsPath.unsafeEncodeUtf offset OsPath.</> p))
|
|
| 409 | 419 | offsetPackageDb _ p = p
|
| 410 | 420 | |
| 411 | 421 | |
| ... | ... | @@ -500,12 +510,12 @@ emptyUnitState = UnitState { |
| 500 | 510 | |
| 501 | 511 | -- | Unit database
|
| 502 | 512 | data UnitDatabase unit = UnitDatabase
|
| 503 | - { unitDatabasePath :: FilePath
|
|
| 513 | + { unitDatabasePath :: OsPath
|
|
| 504 | 514 | , unitDatabaseUnits :: [GenUnitInfo unit]
|
| 505 | 515 | }
|
| 506 | 516 | |
| 507 | 517 | instance Outputable u => Outputable (UnitDatabase u) where
|
| 508 | - ppr (UnitDatabase fp _u) = text "DB:" <+> text fp
|
|
| 518 | + ppr (UnitDatabase fp _u) = text "DB:" <+> OsPath.pprOsPath fp
|
|
| 509 | 519 | |
| 510 | 520 | type UnitInfoMap = UniqMap UnitId UnitInfo
|
| 511 | 521 | |
| ... | ... | @@ -575,10 +585,10 @@ searchPackageId pkgstate pid = filter ((pid ==) . unitPackageId) |
| 575 | 585 | -- | Find the UnitId which an import qualified by a package import comes from.
|
| 576 | 586 | -- Compared to 'lookupPackageName', this function correctly accounts for visibility,
|
| 577 | 587 | -- renaming and thinning.
|
| 578 | -resolvePackageImport :: UnitState -> ModuleName -> PackageName -> Maybe UnitId
|
|
| 579 | -resolvePackageImport unit_st mn pn = do
|
|
| 588 | +resolvePackageImport :: UnitState -> UnitIndexQuery -> ModuleName -> PackageName -> Maybe UnitId
|
|
| 589 | +resolvePackageImport unit_st query mn pn = do
|
|
| 580 | 590 | -- 1. Find all modules providing the ModuleName (this accounts for visibility/thinning etc)
|
| 581 | - providers <- filterUniqMap originVisible <$> lookupUniqMap (moduleNameProvidersMap unit_st) mn
|
|
| 591 | + providers <- filterUniqMap originVisible <$> findOrigin query unit_st mn False
|
|
| 582 | 592 | -- 2. Get the UnitIds of the candidates
|
| 583 | 593 | let candidates_uid = concatMap to_uid $ sortOn fst $ nonDetUniqMapToList providers
|
| 584 | 594 | -- 3. Get the package names of the candidates
|
| ... | ... | @@ -636,14 +646,14 @@ listUnitInfo state = nonDetEltsUniqMap (unitInfoMap state) |
| 636 | 646 | -- 'initUnits' can be called again subsequently after updating the
|
| 637 | 647 | -- 'packageFlags' field of the 'DynFlags', and it will update the
|
| 638 | 648 | -- 'unitState' in 'DynFlags'.
|
| 639 | -initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> Set.Set UnitId -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)
|
|
| 640 | -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
|
|
| 641 | 651 | |
| 642 | 652 | let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()
|
| 643 | 653 | |
| 644 | 654 | (unit_state,dbs) <- withTiming logger (text "initializing unit database")
|
| 645 | 655 | forceUnitInfoMap
|
| 646 | - $ mkUnitState logger (initUnitConfig dflags cached_dbs home_units)
|
|
| 656 | + $ mkUnitState logger (homeUnitId_ dflags) (initUnitConfig dflags cached_dbs home_units) index
|
|
| 647 | 657 | |
| 648 | 658 | putDumpFileMaybe logger Opt_D_dump_mod_map "Module Map"
|
| 649 | 659 | FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})
|
| ... | ... | @@ -720,9 +730,9 @@ getUnitDbRefs cfg = do |
| 720 | 730 | Left _ -> system_conf_refs
|
| 721 | 731 | Right path
|
| 722 | 732 | | Just (xs, x) <- snocView path, isSearchPathSeparator x
|
| 723 | - -> map PkgDbPath (splitSearchPath xs) ++ system_conf_refs
|
|
| 733 | + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf xs)) ++ system_conf_refs
|
|
| 724 | 734 | | otherwise
|
| 725 | - -> map PkgDbPath (splitSearchPath path)
|
|
| 735 | + -> map PkgDbPath (OsPath.splitSearchPath (OsPath.unsafeEncodeUtf path))
|
|
| 726 | 736 | |
| 727 | 737 | -- Apply the package DB-related flags from the command line to get the
|
| 728 | 738 | -- final list of package DBs.
|
| ... | ... | @@ -751,24 +761,24 @@ getUnitDbRefs cfg = do |
| 751 | 761 | -- NB: This logic is reimplemented in Cabal, so if you change it,
|
| 752 | 762 | -- make sure you update Cabal. (Or, better yet, dump it in the
|
| 753 | 763 | -- compiler info so Cabal can use the info.)
|
| 754 | -resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath)
|
|
| 755 | -resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg)
|
|
| 764 | +resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe OsPath)
|
|
| 765 | +resolveUnitDatabase cfg GlobalPkgDb = return $ Just $ OsPath.unsafeEncodeUtf $ unitConfigGlobalDB cfg
|
|
| 756 | 766 | resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do
|
| 757 | 767 | dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg)
|
| 758 | 768 | let pkgconf = dir </> unitConfigDBName cfg
|
| 759 | 769 | exist <- tryMaybeT $ doesDirectoryExist pkgconf
|
| 760 | - if exist then return pkgconf else mzero
|
|
| 770 | + if exist then return (OsPath.unsafeEncodeUtf pkgconf) else mzero
|
|
| 761 | 771 | resolveUnitDatabase _ (PkgDbPath name) = return $ Just name
|
| 762 | 772 | |
| 763 | -readUnitDatabase :: Logger -> UnitConfig -> FilePath -> IO (UnitDatabase UnitId)
|
|
| 773 | +readUnitDatabase :: Logger -> UnitConfig -> OsPath -> IO (UnitDatabase UnitId)
|
|
| 764 | 774 | readUnitDatabase logger cfg conf_file = do
|
| 765 | - isdir <- doesDirectoryExist conf_file
|
|
| 775 | + isdir <- OsPath.doesDirectoryExist conf_file
|
|
| 766 | 776 | |
| 767 | 777 | proto_pkg_configs <-
|
| 768 | 778 | if isdir
|
| 769 | 779 | then readDirStyleUnitInfo conf_file
|
| 770 | 780 | else do
|
| 771 | - isfile <- doesFileExist conf_file
|
|
| 781 | + isfile <- OsPath.doesFileExist conf_file
|
|
| 772 | 782 | if isfile
|
| 773 | 783 | then do
|
| 774 | 784 | mpkgs <- tryReadOldFileStyleUnitInfo
|
| ... | ... | @@ -776,48 +786,49 @@ readUnitDatabase logger cfg conf_file = do |
| 776 | 786 | Just pkgs -> return pkgs
|
| 777 | 787 | Nothing -> throwGhcExceptionIO $ InstallationError $
|
| 778 | 788 | "ghc no longer supports single-file style package " ++
|
| 779 | - "databases (" ++ conf_file ++
|
|
| 789 | + "databases (" ++ show conf_file ++
|
|
| 780 | 790 | ") use 'ghc-pkg init' to create the database with " ++
|
| 781 | 791 | "the correct format."
|
| 782 | 792 | else throwGhcExceptionIO $ InstallationError $
|
| 783 | - "can't find a package database at " ++ conf_file
|
|
| 793 | + "can't find a package database at " ++ show conf_file
|
|
| 784 | 794 | |
| 785 | 795 | let
|
| 786 | 796 | -- Fix #16360: remove trailing slash from conf_file before calculating pkgroot
|
| 787 | - conf_file' = dropTrailingPathSeparator conf_file
|
|
| 788 | - top_dir = unitConfigGHCDir cfg
|
|
| 789 | - pkgroot = takeDirectory conf_file'
|
|
| 797 | + conf_file' = OsPath.dropTrailingPathSeparator conf_file
|
|
| 798 | + top_dir = OsPath.unsafeEncodeUtf (unitConfigGHCDir cfg) -- TODO: hm.
|
|
| 799 | + pkgroot = OsPath.takeDirectory conf_file'
|
|
| 790 | 800 | pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)
|
| 791 | 801 | proto_pkg_configs
|
| 792 | 802 | --
|
| 793 | 803 | return $ UnitDatabase conf_file' pkg_configs1
|
| 794 | 804 | where
|
| 805 | + readDirStyleUnitInfo :: OsPath -> IO [DbUnitInfo]
|
|
| 795 | 806 | readDirStyleUnitInfo conf_dir = do
|
| 796 | - let filename = conf_dir </> "package.cache"
|
|
| 797 | - cache_exists <- doesFileExist filename
|
|
| 807 | + let filename = conf_dir OsPath.</> (OsPath.unsafeEncodeUtf "package.cache")
|
|
| 808 | + cache_exists <- OsPath.doesFileExist filename
|
|
| 798 | 809 | if cache_exists
|
| 799 | 810 | then do
|
| 800 | - debugTraceMsg logger 2 $ text "Using binary package database:" <+> text filename
|
|
| 801 | - readPackageDbForGhc filename
|
|
| 811 | + debugTraceMsg logger 2 $ text "Using binary package database:" <+> OsPath.pprOsPath filename
|
|
| 812 | + readPackageDbForGhc (OsPath.unsafeDecodeUtf filename) -- TODO: Can we help it with this one? it comes from the ghc-boot package
|
|
| 802 | 813 | else do
|
| 803 | 814 | -- If there is no package.cache file, we check if the database is not
|
| 804 | 815 | -- empty by inspecting if the directory contains any .conf file. If it
|
| 805 | 816 | -- does, something is wrong and we fail. Otherwise we assume that the
|
| 806 | 817 | -- database is empty.
|
| 807 | 818 | debugTraceMsg logger 2 $ text "There is no package.cache in"
|
| 808 | - <+> text conf_dir
|
|
| 819 | + <+> OsPath.pprOsPath conf_dir
|
|
| 809 | 820 | <> text ", checking if the database is empty"
|
| 810 | - db_empty <- all (not . isSuffixOf ".conf")
|
|
| 811 | - <$> getDirectoryContents conf_dir
|
|
| 821 | + db_empty <- all (not . OsPath.isSuffixOf (OsPath.unsafeEncodeUtf ".conf"))
|
|
| 822 | + <$> OsPath.getDirectoryContents conf_dir
|
|
| 812 | 823 | if db_empty
|
| 813 | 824 | then do
|
| 814 | 825 | debugTraceMsg logger 3 $ text "There are no .conf files in"
|
| 815 | - <+> text conf_dir <> text ", treating"
|
|
| 826 | + <+> OsPath.pprOsPath conf_dir <> text ", treating"
|
|
| 816 | 827 | <+> text "package database as empty"
|
| 817 | 828 | return []
|
| 818 | 829 | else
|
| 819 | 830 | throwGhcExceptionIO $ InstallationError $
|
| 820 | - "there is no package.cache in " ++ conf_dir ++
|
|
| 831 | + "there is no package.cache in " ++ show conf_dir ++
|
|
| 821 | 832 | " even though package database is not empty"
|
| 822 | 833 | |
| 823 | 834 | |
| ... | ... | @@ -830,13 +841,13 @@ readUnitDatabase logger cfg conf_file = do |
| 830 | 841 | -- assumes it's a file and tries to overwrite with 'writeFile'.
|
| 831 | 842 | -- ghc-pkg also cooperates with this workaround.
|
| 832 | 843 | tryReadOldFileStyleUnitInfo = do
|
| 833 | - content <- readFile conf_file `catchIO` \_ -> return ""
|
|
| 844 | + content <- readFile (OsPath.unsafeDecodeUtf conf_file) `catchIO` \_ -> return ""
|
|
| 834 | 845 | if take 2 content == "[]"
|
| 835 | 846 | then do
|
| 836 | - let conf_dir = conf_file <.> "d"
|
|
| 837 | - direxists <- doesDirectoryExist conf_dir
|
|
| 847 | + let conf_dir = conf_file OsPath.<.> OsPath.unsafeEncodeUtf "d"
|
|
| 848 | + direxists <- OsPath.doesDirectoryExist conf_dir
|
|
| 838 | 849 | if direxists
|
| 839 | - then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
|
|
| 850 | + then do debugTraceMsg logger 2 (text "Ignoring old file-style db and trying:" <+> OsPath.pprOsPath conf_dir)
|
|
| 840 | 851 | liftM Just (readDirStyleUnitInfo conf_dir)
|
| 841 | 852 | else return (Just []) -- ghc-pkg will create it when it's updated
|
| 842 | 853 | else return Nothing
|
| ... | ... | @@ -846,11 +857,12 @@ distrustAllUnits pkgs = map distrust pkgs |
| 846 | 857 | where
|
| 847 | 858 | distrust pkg = pkg{ unitIsTrusted = False }
|
| 848 | 859 | |
| 849 | -mungeUnitInfo :: FilePath -> FilePath
|
|
| 860 | +-- TODO: Can we help it with this one? it comes from the ghc-boot package
|
|
| 861 | +mungeUnitInfo :: OsPath -> OsPath
|
|
| 850 | 862 | -> UnitInfo -> UnitInfo
|
| 851 | 863 | mungeUnitInfo top_dir pkgroot =
|
| 852 | 864 | mungeDynLibFields
|
| 853 | - . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot)
|
|
| 865 | + . mungeUnitInfoPaths (ST.pack (OsPath.unsafeDecodeUtf top_dir)) (ST.pack (OsPath.unsafeDecodeUtf pkgroot))
|
|
| 854 | 866 | |
| 855 | 867 | mungeDynLibFields :: UnitInfo -> UnitInfo
|
| 856 | 868 | mungeDynLibFields pkg =
|
| ... | ... | @@ -1388,7 +1400,7 @@ mergeDatabases logger = foldM merge (emptyUniqMap, emptyUniqMap) . zip [1..] |
| 1388 | 1400 | where
|
| 1389 | 1401 | merge (pkg_map, prec_map) (i, UnitDatabase db_path db) = do
|
| 1390 | 1402 | debugTraceMsg logger 2 $
|
| 1391 | - text "loading package database" <+> text db_path
|
|
| 1403 | + text "loading package database" <+> OsPath.pprOsPath db_path
|
|
| 1392 | 1404 | forM_ (Set.toList override_set) $ \pkg ->
|
| 1393 | 1405 | debugTraceMsg logger 2 $
|
| 1394 | 1406 | text "package" <+> ppr pkg <+>
|
| ... | ... | @@ -1480,9 +1492,11 @@ validateDatabase cfg pkg_map1 = |
| 1480 | 1492 | |
| 1481 | 1493 | mkUnitState
|
| 1482 | 1494 | :: Logger
|
| 1495 | + -> UnitId
|
|
| 1483 | 1496 | -> UnitConfig
|
| 1497 | + -> UnitIndex
|
|
| 1484 | 1498 | -> IO (UnitState,[UnitDatabase UnitId])
|
| 1485 | -mkUnitState logger cfg = do
|
|
| 1499 | +mkUnitState logger unit cfg index = do
|
|
| 1486 | 1500 | {-
|
| 1487 | 1501 | Plan.
|
| 1488 | 1502 | |
| ... | ... | @@ -1538,15 +1552,9 @@ mkUnitState logger cfg = do |
| 1538 | 1552 | |
| 1539 | 1553 | -- if databases have not been provided, read the database flags
|
| 1540 | 1554 | raw_dbs <- case unitConfigDBCache cfg of
|
| 1541 | - Nothing -> readUnitDatabases logger cfg
|
|
| 1555 | + Nothing -> readDatabases index logger unit cfg
|
|
| 1542 | 1556 | Just dbs -> return dbs
|
| 1543 | 1557 | |
| 1544 | - -- distrust all units if the flag is set
|
|
| 1545 | - let distrust_all db = db { unitDatabaseUnits = distrustAllUnits (unitDatabaseUnits db) }
|
|
| 1546 | - dbs | unitConfigDistrustAll cfg = map distrust_all raw_dbs
|
|
| 1547 | - | otherwise = raw_dbs
|
|
| 1548 | - |
|
| 1549 | - |
|
| 1550 | 1558 | -- This, and the other reverse's that you will see, are due to the fact that
|
| 1551 | 1559 | -- packageFlags, pluginPackageFlags, etc. are all specified in *reverse* order
|
| 1552 | 1560 | -- than they are on the command line.
|
| ... | ... | @@ -1558,15 +1566,20 @@ mkUnitState logger cfg = do |
| 1558 | 1566 | let home_unit_deps = selectHomeUnits (unitConfigHomeUnits cfg) hpt_flags
|
| 1559 | 1567 | |
| 1560 | 1568 | -- Merge databases together, without checking validity
|
| 1561 | - (pkg_map1, prec_map) <- mergeDatabases logger dbs
|
|
| 1569 | + (pkg_map1, prec_map) <- mergeDatabases logger raw_dbs
|
|
| 1562 | 1570 | |
| 1563 | 1571 | -- Now that we've merged everything together, prune out unusable
|
| 1564 | 1572 | -- packages.
|
| 1565 | - let (pkg_map2, unusable, sccs) = validateDatabase cfg pkg_map1
|
|
| 1573 | + let (initial_dbs, unusable, sccs) = validateDatabase cfg pkg_map1
|
|
| 1566 | 1574 | |
| 1567 | 1575 | reportCycles logger sccs
|
| 1568 | 1576 | reportUnusable logger unusable
|
| 1569 | 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 | + |
|
| 1570 | 1583 | -- Apply trust flags (these flags apply regardless of whether
|
| 1571 | 1584 | -- or not packages are visible or not)
|
| 1572 | 1585 | pkgs1 <- mayThrowUnitErr
|
| ... | ... | @@ -1671,6 +1684,9 @@ mkUnitState logger cfg = do |
| 1671 | 1684 | -- likely to actually happen.
|
| 1672 | 1685 | return (updateVisibilityMap wired_map plugin_vis_map2)
|
| 1673 | 1686 | |
| 1687 | + (moduleNameProvidersMap, pluginModuleNameProvidersMap) <-
|
|
| 1688 | + computeProviders index logger unit cfg vis_map plugin_vis_map initial_dbs pkg_db (mkUnusableModuleNameProvidersMap unusable)
|
|
| 1689 | + |
|
| 1674 | 1690 | let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)
|
| 1675 | 1691 | | p <- pkgs2
|
| 1676 | 1692 | ]
|
| ... | ... | @@ -1683,8 +1699,6 @@ mkUnitState logger cfg = do |
| 1683 | 1699 | req_ctx = mapUniqMap (Set.toList)
|
| 1684 | 1700 | $ plusUniqMapListWith Set.union (map uv_requirements (nonDetEltsUniqMap vis_map))
|
| 1685 | 1701 | |
| 1686 | - |
|
| 1687 | - --
|
|
| 1688 | 1702 | -- Here we build up a set of the packages mentioned in -package
|
| 1689 | 1703 | -- flags on the command line; these are called the "preload"
|
| 1690 | 1704 | -- packages. we link these packages in eagerly. The preload set
|
| ... | ... | @@ -1707,10 +1721,6 @@ mkUnitState logger cfg = do |
| 1707 | 1721 | $ closeUnitDeps pkg_db
|
| 1708 | 1722 | $ zip (map toUnitId preload3) (repeat Nothing)
|
| 1709 | 1723 | |
| 1710 | - let mod_map1 = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet vis_map
|
|
| 1711 | - mod_map2 = mkUnusableModuleNameProvidersMap unusable
|
|
| 1712 | - mod_map = mod_map2 `plusUniqMap` mod_map1
|
|
| 1713 | - |
|
| 1714 | 1724 | -- Force the result to avoid leaking input parameters
|
| 1715 | 1725 | let !state = UnitState
|
| 1716 | 1726 | { preloadUnits = dep_preload
|
| ... | ... | @@ -1718,8 +1728,8 @@ mkUnitState logger cfg = do |
| 1718 | 1728 | , homeUnitDepends = Set.toList home_unit_deps
|
| 1719 | 1729 | , unitInfoMap = pkg_db
|
| 1720 | 1730 | , preloadClosure = emptyUniqSet
|
| 1721 | - , moduleNameProvidersMap = mod_map
|
|
| 1722 | - , pluginModuleNameProvidersMap = mkModuleNameProvidersMap logger cfg pkg_db emptyUniqSet plugin_vis_map
|
|
| 1731 | + , moduleNameProvidersMap
|
|
| 1732 | + , pluginModuleNameProvidersMap
|
|
| 1723 | 1733 | , packageNameMap = pkgname_map
|
| 1724 | 1734 | , wireMap = wired_map
|
| 1725 | 1735 | , unwireMap = listToUniqMap [ (v,k) | (k,v) <- nonDetUniqMapToList wired_map ]
|
| ... | ... | @@ -1892,6 +1902,76 @@ addListTo = foldl' merge |
| 1892 | 1902 | mkModMap :: Unit -> ModuleName -> ModuleOrigin -> UniqMap Module ModuleOrigin
|
| 1893 | 1903 | mkModMap pkg mod = unitUniqMap (mkModule pkg mod)
|
| 1894 | 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 | + }
|
|
| 1895 | 1975 | |
| 1896 | 1976 | -- -----------------------------------------------------------------------------
|
| 1897 | 1977 | -- Package Utils
|
| ... | ... | @@ -1899,10 +1979,11 @@ mkModMap pkg mod = unitUniqMap (mkModule pkg mod) |
| 1899 | 1979 | -- | Takes a 'ModuleName', and if the module is in any package returns
|
| 1900 | 1980 | -- list of modules which take that name.
|
| 1901 | 1981 | lookupModuleInAllUnits :: UnitState
|
| 1982 | + -> UnitIndexQuery
|
|
| 1902 | 1983 | -> ModuleName
|
| 1903 | 1984 | -> [(Module, UnitInfo)]
|
| 1904 | -lookupModuleInAllUnits pkgs m
|
|
| 1905 | - = case lookupModuleWithSuggestions pkgs m NoPkgQual of
|
|
| 1985 | +lookupModuleInAllUnits pkgs query m
|
|
| 1986 | + = case lookupModuleWithSuggestions pkgs query m NoPkgQual of
|
|
| 1906 | 1987 | LookupFound a b -> [(a,fst b)]
|
| 1907 | 1988 | LookupMultiple rs -> map f rs
|
| 1908 | 1989 | where f (m,_) = (m, expectJust "lookupModule" (lookupUnit pkgs
|
| ... | ... | @@ -1929,18 +2010,24 @@ data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin |
| 1929 | 2010 | | SuggestHidden ModuleName Module ModuleOrigin
|
| 1930 | 2011 | |
| 1931 | 2012 | lookupModuleWithSuggestions :: UnitState
|
| 2013 | + -> UnitIndexQuery
|
|
| 1932 | 2014 | -> ModuleName
|
| 1933 | 2015 | -> PkgQual
|
| 1934 | 2016 | -> LookupResult
|
| 1935 | -lookupModuleWithSuggestions pkgs
|
|
| 1936 | - = lookupModuleWithSuggestions' pkgs (moduleNameProvidersMap pkgs)
|
|
| 2017 | +lookupModuleWithSuggestions pkgs query name
|
|
| 2018 | + = lookupModuleWithSuggestions' pkgs query name False
|
|
| 1937 | 2019 | |
| 1938 | 2020 | -- | The package which the module **appears** to come from, this could be
|
| 1939 | 2021 | -- the one which reexports the module from it's original package. This function
|
| 1940 | 2022 | -- is currently only used for -Wunused-packages
|
| 1941 | -lookupModulePackage :: UnitState -> ModuleName -> PkgQual -> Maybe [UnitInfo]
|
|
| 1942 | -lookupModulePackage pkgs mn mfs =
|
|
| 1943 | - 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
|
|
| 1944 | 2031 | LookupFound _ (orig_unit, origin) ->
|
| 1945 | 2032 | case origin of
|
| 1946 | 2033 | ModOrigin {fromOrigUnit, fromExposedReexport} ->
|
| ... | ... | @@ -1956,19 +2043,21 @@ lookupModulePackage pkgs mn mfs = |
| 1956 | 2043 | _ -> Nothing
|
| 1957 | 2044 | |
| 1958 | 2045 | lookupPluginModuleWithSuggestions :: UnitState
|
| 2046 | + -> UnitIndexQuery
|
|
| 1959 | 2047 | -> ModuleName
|
| 1960 | 2048 | -> PkgQual
|
| 1961 | 2049 | -> LookupResult
|
| 1962 | -lookupPluginModuleWithSuggestions pkgs
|
|
| 1963 | - = lookupModuleWithSuggestions' pkgs (pluginModuleNameProvidersMap pkgs)
|
|
| 2050 | +lookupPluginModuleWithSuggestions pkgs query name
|
|
| 2051 | + = lookupModuleWithSuggestions' pkgs query name True
|
|
| 1964 | 2052 | |
| 1965 | 2053 | lookupModuleWithSuggestions' :: UnitState
|
| 1966 | - -> ModuleNameProvidersMap
|
|
| 2054 | + -> UnitIndexQuery
|
|
| 1967 | 2055 | -> ModuleName
|
| 2056 | + -> Bool
|
|
| 1968 | 2057 | -> PkgQual
|
| 1969 | 2058 | -> LookupResult
|
| 1970 | -lookupModuleWithSuggestions' pkgs mod_map m mb_pn
|
|
| 1971 | - = case lookupUniqMap mod_map m of
|
|
| 2059 | +lookupModuleWithSuggestions' pkgs query m onlyPlugins mb_pn
|
|
| 2060 | + = case findOrigin query pkgs m onlyPlugins of
|
|
| 1972 | 2061 | Nothing -> LookupNotFound suggestions
|
| 1973 | 2062 | Just xs ->
|
| 1974 | 2063 | case foldl' classify ([],[],[], []) (sortOn fst $ nonDetUniqMapToList xs) of
|
| ... | ... | @@ -2029,16 +2118,16 @@ lookupModuleWithSuggestions' pkgs mod_map m mb_pn |
| 2029 | 2118 | all_mods :: [(String, ModuleSuggestion)] -- All modules
|
| 2030 | 2119 | all_mods = sortBy (comparing fst) $
|
| 2031 | 2120 | [ (moduleNameString m, suggestion)
|
| 2032 | - | (m, e) <- nonDetUniqMapToList (moduleNameProvidersMap pkgs)
|
|
| 2121 | + | (m, e) <- nonDetUniqMapToList (moduleProviders query pkgs)
|
|
| 2033 | 2122 | , suggestion <- map (getSuggestion m) (nonDetUniqMapToList e)
|
| 2034 | 2123 | ]
|
| 2035 | 2124 | getSuggestion name (mod, origin) =
|
| 2036 | 2125 | (if originVisible origin then SuggestVisible else SuggestHidden)
|
| 2037 | 2126 | name mod origin
|
| 2038 | 2127 | |
| 2039 | -listVisibleModuleNames :: UnitState -> [ModuleName]
|
|
| 2040 | -listVisibleModuleNames state =
|
|
| 2041 | - 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)))
|
|
| 2042 | 2131 | where visible (_, ms) = anyUniqMap originVisible ms
|
| 2043 | 2132 | |
| 2044 | 2133 | -- | Takes a list of UnitIds (and their "parent" dependency, used for error
|
| ... | ... | @@ -115,6 +115,7 @@ Library |
| 115 | 115 | containers >= 0.6.2.1 && < 0.8,
|
| 116 | 116 | array >= 0.1 && < 0.6,
|
| 117 | 117 | filepath >= 1 && < 1.6,
|
| 118 | + os-string >= 2.0.1 && < 2.1,
|
|
| 118 | 119 | template-haskell == 2.22.*,
|
| 119 | 120 | hpc >= 0.6 && < 0.8,
|
| 120 | 121 | transformers >= 0.5 && < 0.7,
|
| ... | ... | @@ -430,6 +431,7 @@ Library |
| 430 | 431 | GHC.Data.List.SetOps
|
| 431 | 432 | GHC.Data.Maybe
|
| 432 | 433 | GHC.Data.OrdList
|
| 434 | + GHC.Data.OsPath
|
|
| 433 | 435 | GHC.Data.Pair
|
| 434 | 436 | GHC.Data.SmallArray
|
| 435 | 437 | GHC.Data.Stream
|
| ... | ... | @@ -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 |