[Git][ghc/ghc][wip/fendor/ghci-multiple-home-units] 2 commits: Use Module in IIModule
Hannes Siebenhandl pushed to branch wip/fendor/ghci-multiple-home-units at Glasgow Haskell Compiler / GHC Commits: b7b39d81 by fendor at 2025-04-23T17:50:25+02:00 Use Module in IIModule - - - - - 6e49609d by fendor at 2025-04-23T17:50:25+02:00 WIP - - - - - 20 changed files: - compiler/GHC.hs - compiler/GHC/Rename/Unbound.hs - compiler/GHC/Runtime/Context.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Unit/Home/Graph.hs - ghc/GHCi/UI.hs - testsuite/tests/ghci/linking/dyn/T3372.hs - testsuite/tests/ghci/prog018/prog018.stdout - testsuite/tests/ghci/scripts/T13869.stdout - testsuite/tests/ghci/scripts/T13997.stdout - testsuite/tests/ghci/scripts/T17669.stdout - testsuite/tests/ghci/scripts/T18330.stdout - testsuite/tests/ghci/scripts/T1914.stdout - testsuite/tests/ghci/scripts/T20217.stdout - testsuite/tests/ghci/scripts/T20587.stdout - testsuite/tests/ghci/scripts/T6105.stdout - testsuite/tests/ghci/scripts/T8042.stdout - testsuite/tests/ghci/scripts/T8042recomp.stdout - testsuite/tests/ghci/should_run/TopEnvIface.stdout Changes: ===================================== compiler/GHC.hs ===================================== @@ -40,6 +40,7 @@ module GHC ( getProgramDynFlags, setProgramDynFlags, updateProgramDynFlags, getInteractiveDynFlags, setInteractiveDynFlags, + normaliseInteractiveDynFlags, initialiseInteractiveDynFlags, interpretPackageEnv, -- * Logging @@ -157,7 +158,7 @@ module GHC ( getBindings, getInsts, getNamePprCtx, findModule, lookupModule, findQualifiedModule, lookupQualifiedModule, - lookupLoadedHomeModuleByModuleName, lookupAnyQualifiedModule, + lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames, renamePkgQualM, renameRawPkgQualM, isModuleTrusted, moduleTrustReqs, getNamesInScope, @@ -962,24 +963,8 @@ getProgramDynFlags = getSessionDynFlags setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do logger <- getLogger - dflags' <- checkNewDynFlags logger dflags - dflags'' <- checkNewInteractiveDynFlags logger dflags' - modifySessionM $ \hsc_env0 -> do - let ic0 = hsc_IC hsc_env0 - - -- Initialise (load) plugins in the interactive environment with the new - -- DynFlags - plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ - hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }} - - -- Update both plugins cache and DynFlags in the interactive context. - return $ hsc_env0 - { hsc_IC = ic0 - { ic_plugins = hsc_plugins plugin_env - , ic_dflags = hsc_dflags plugin_env - } - } - + icdflags <- normaliseInteractiveDynFlags logger dflags + modifySessionM (initialiseInteractiveDynFlags icdflags) -- | Get the 'DynFlags' used to evaluate interactive expressions. getInteractiveDynFlags :: GhcMonad m => m DynFlags @@ -1084,6 +1069,28 @@ normalise_hyp fp ----------------------------------------------------------------------------- +normaliseInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags +normaliseInteractiveDynFlags logger dflags = do + dflags' <- checkNewDynFlags logger dflags + checkNewInteractiveDynFlags logger dflags' + +initialiseInteractiveDynFlags :: GhcMonad m => DynFlags -> HscEnv -> m HscEnv +initialiseInteractiveDynFlags dflags hsc_env0 = do + let ic0 = hsc_IC hsc_env0 + + -- Initialise (load) plugins in the interactive environment with the new + -- DynFlags + plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $ + hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags }} + + -- Update both plugins cache and DynFlags in the interactive context. + return $ hsc_env0 + { hsc_IC = ic0 + { ic_plugins = hsc_plugins plugin_env + , ic_dflags = hsc_dflags plugin_env + } + } + -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible). @@ -1496,8 +1503,8 @@ getModuleGraph = liftM hsc_mod_graph getSession -- TODO: this function should likely be deleted. isLoaded :: GhcMonad m => ModuleName -> m Bool isLoaded m = withSession $ \hsc_env -> liftIO $ do - hmi <- HUG.lookupAnyHug (hsc_HUG hsc_env) m - return $! isJust hmi + hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m + return $! not (null hmis) isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do @@ -1895,18 +1902,16 @@ lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env -> liftIO $ do Just mod_info -> return (Just (mi_module (hm_iface mod_info))) _not_a_home_module -> return Nothing --- TODO: this is incorrect, what if we have mulitple 'ModuleName's in our HPTs? -lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe Module) +lookupLoadedHomeModuleByModuleName :: GhcMonad m => ModuleName -> m (Maybe [Module]) lookupLoadedHomeModuleByModuleName mod_name = withSession $ \hsc_env -> liftIO $ do trace_if (hsc_logger hsc_env) (text "lookupLoadedHomeModuleByModuleName" <+> ppr mod_name) - HUG.lookupAnyHug (hsc_HUG hsc_env) mod_name >>= \case - Just mod_info -> return (Just (mi_module (hm_iface mod_info))) - _not_a_home_module -> return Nothing + HUG.lookupAllHug (hsc_HUG hsc_env) mod_name >>= \case + [] -> return Nothing + mod_infos -> return (Just (mi_module . hm_iface <$> mod_infos)) -lookupAnyQualifiedModule :: GhcMonad m => PkgQual -> ModuleName -> m Module -lookupAnyQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do +lookupAllQualifiedModuleNames :: GhcMonad m => PkgQual -> ModuleName -> m [Module] +lookupAllQualifiedModuleNames NoPkgQual mod_name = withSession $ \hsc_env -> do home <- lookupLoadedHomeModuleByModuleName mod_name - liftIO $ trace_if (hsc_logger hsc_env) (ppr home <+> ppr (fmap moduleUnitId home)) case home of Just m -> return m Nothing -> liftIO $ do @@ -1916,11 +1921,11 @@ lookupAnyQualifiedModule NoPkgQual mod_name = withSession $ \hsc_env -> do let fopts = initFinderOpts dflags res <- findExposedPackageModule fc fopts units mod_name NoPkgQual case res of - Found _ m -> return m + Found _ m -> return [m] err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err -lookupAnyQualifiedModule pkgqual mod_name = - -- TODO: definitely wrong. - findQualifiedModule pkgqual mod_name +lookupAllQualifiedModuleNames pkgqual mod_name = do + m <- findQualifiedModule pkgqual mod_name + pure [m] -- | Check that a module is safe to import (according to Safe Haskell). -- ===================================== compiler/GHC/Rename/Unbound.hs ===================================== @@ -364,7 +364,7 @@ importSuggestions looking_for ic currMod imports rdr_name pick_interactive :: InteractiveImport -> Bool pick_interactive (IIDecl d) | mod_name == Just (unLoc (ideclName d)) = True | mod_name == fmap unLoc (ideclAs d) = True - pick_interactive (IIModule m) | mod_name == Just m = True + pick_interactive (IIModule m) | mod_name == Just (moduleName m) = True pick_interactive _ = False -- We want to keep only one for each original module; preferably one with an ===================================== compiler/GHC/Runtime/Context.hs ===================================== @@ -296,9 +296,7 @@ data InteractiveImport -- ^ Bring the exports of a particular module -- (filtered by an import decl) into scope - | IIModule ModuleName - -- TODO: change this to 'Module', does this work? - -- Much more precise + | IIModule Module -- ^ Bring into scope the entire top-level envt of -- of this module, including the things imported -- into it. ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -822,17 +822,12 @@ findGlobalRdrEnv hsc_env imports idecls :: [LImportDecl GhcPs] idecls = [noLocA d | IIDecl d <- imports] - imods :: [ModuleName] + imods :: [Module] imods = [m | IIModule m <- imports] - mkEnv modl = do - -- TODO: revisit this, is this how we want to do it? - mMod <- HUG.lookupAnyHug (hsc_HUG hsc_env) modl - let mod = case mMod of - Nothing -> mkModule (RealUnit $ Definite $ hscActiveUnitId hsc_env) modl - Just m -> mi_module $ hm_iface m + mkEnv mod = do mkTopLevEnv hsc_env mod >>= \case - Left err -> pure $ Left (modl, err) + Left err -> pure $ Left (moduleName mod, err) Right env -> pure $ Right env mkTopLevEnv :: HscEnv -> Module -> IO (Either String GlobalRdrEnv) ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -150,7 +150,6 @@ import GHC.Types.Basic hiding( SuccessFlag(..) ) import GHC.Types.Annotations import GHC.Types.SrcLoc import GHC.Types.SourceFile -import GHC.Types.PkgQual import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Env as UnitEnv @@ -2091,15 +2090,18 @@ runTcInteractive hsc_env thing_inside , let local_gres = filter isLocalGRE gres , not (null local_gres) ]) ] - ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface - : dep_orphs (mi_deps iface)) - (loadSrcInterface (text "runTcInteractive") m - NotBoot mb_pkg) + ; let getOrphansForModuleName m mb_pkg = do + iface <- loadSrcInterface (text "runTcInteractive") m NotBoot mb_pkg + pure $ mi_module iface : dep_orphs (mi_deps iface) + + getOprhansForModule m = do + iface <- loadModuleInterface (text "runTcInteractive") m + pure $ mi_module iface : dep_orphs (mi_deps iface) ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i -> case i of -- force above: see #15111 - IIModule n -> getOrphans n NoPkgQual - IIDecl i -> getOrphans (unLoc (ideclName i)) + IIModule n -> getOprhansForModule n + IIDecl i -> getOrphansForModuleName (unLoc (ideclName i)) (renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)) ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -34,7 +34,7 @@ module GHC.Unit.Home.Graph , lookupHug , lookupHugByModule , lookupHugUnit - , lookupAnyHug + , lookupAllHug , memberHugHomeModule , memberHugHomeInstalledModule @@ -91,6 +91,7 @@ import GHC.Data.Graph.Directed import GHC.Types.Annotations import GHC.Types.CompleteMatch import GHC.Core.InstEnv +import GHC.Utils.Monad (mapMaybeM) -- | Get all 'CompleteMatches' (arising from COMPLETE pragmas) present across @@ -254,22 +255,17 @@ lookupHug hug uid mod = do Nothing -> pure Nothing Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod --- TODO: this should not be merged, where else could we try to search for modules? -lookupAnyHug :: HomeUnitGraph -> ModuleName -> IO (Maybe HomeModInfo) -lookupAnyHug hug mod = firstJustM $ flip fmap (Set.toList $ unitEnv_keys hug) $ \uid -> do - case unitEnv_lookup_maybe uid hug of - -- Really, here we want "lookup HPT" rather than unitEnvLookup - Nothing -> pure Nothing - Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod +-- | Lookup all 'HomeModInfo' that have the same 'ModuleName' as the given 'ModuleName'. +-- 'ModuleName's are not unique in the case of multiple home units, so there can be +-- more than one possible 'HomeModInfo'. +lookupAllHug :: HomeUnitGraph -> ModuleName -> IO [HomeModInfo] +lookupAllHug hug mod = mapMaybeM lookupModuleName (Set.toList $ unitEnv_keys hug) where - firstJustM :: Monad f => [f (Maybe a)] -> f (Maybe a) - firstJustM [] = pure Nothing - firstJustM (x:xs) = do - ma <- x - case ma of - Nothing -> firstJustM xs - Just a -> pure $ Just a - + lookupModuleName uid = + case unitEnv_lookup_maybe uid hug of + -- Really, here we want "lookup HPT" rather than unitEnvLookup + Nothing -> pure Nothing + Just hue -> lookupHpt (homeUnitEnv_hpt hue) mod -- | Lookup the 'HomeModInfo' of a 'Module' in the 'HomeUnitGraph' (via the 'HomePackageTable' of the corresponding unit) lookupHugByModule :: Module -> HomeUnitGraph -> IO (Maybe HomeModInfo) @@ -283,10 +279,12 @@ lookupHugByModule mod hug lookupHugUnit :: UnitId -> HomeUnitGraph -> Maybe HomeUnitEnv lookupHugUnit = unitEnv_lookup_maybe +-- | Check whether the 'Module' is part of the given 'HomeUnitGraph'. memberHugHomeModule :: Module -> HomeUnitGraph -> Bool memberHugHomeModule mod = memberHugHomeInstalledModule (fmap toUnitId mod) +-- | Check whether the 'InstalledModule' is part of the given 'HomeUnitGraph'. memberHugHomeInstalledModule :: InstalledModule -> HomeUnitGraph -> Bool memberHugHomeInstalledModule mod hug = case unitEnv_lookup_maybe (moduleUnit mod) hug of ===================================== ghc/GHCi/UI.hs ===================================== @@ -558,7 +558,7 @@ interactiveUI config srcs maybe_exprs = do hsc_env <- GHC.getSession let !in_multi = length (hsc_all_home_unit_ids hsc_env) > 3 -- We force this to make sure we don't retain the hsc_env when reloading - -- The check is `> 2`, since we now always have at least two home units. + -- The check is `> 3`, since we now always have at least two home units. -- TODO: if everything goes well, this check should be deleted once -- this PR has lifted the multiple home unit restrictions empty_cache <- liftIO newIfaceCache @@ -1023,7 +1023,7 @@ getInfoForPrompt = do | otherwise = unLoc (ideclName d) modules_names = - ['*':(moduleNameString m) | IIModule m <- rev_imports] ++ + ['*':(moduleNameString (moduleName m)) | IIModule m <- rev_imports] ++ [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports] line = 1 + line_number st @@ -1444,7 +1444,6 @@ runStmt input step = do setDumpFilePrefix :: GHC.GhcMonad m => InteractiveContext -> m () -- #17500 setDumpFilePrefix ic = do - -- TODO: wrong dflags <- GHC.getInteractiveDynFlags GHC.setInteractiveDynFlags dflags { dumpPrefix = modStr ++ "." } where @@ -2122,7 +2121,7 @@ addModule :: GhciMonad m => [FilePath] -> m () addModule files = do revertCAFs -- always revert CAFs on load/add. files' <- mapM expandPath files - targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files' + targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files' targets' <- filterM checkTarget targets -- remove old targets with the same id; e.g. for :add *M mapM_ GHC.removeTarget [ tid | Target { targetId = tid } <- targets' ] @@ -2155,7 +2154,7 @@ addModule files = do unAddModule :: GhciMonad m => [FilePath] -> m () unAddModule files = do files' <- mapM expandPath files - targets <- mapM (\m -> GHC.guessTarget m Nothing Nothing) files' + targets <- mapM (\m -> GHC.guessTarget m (Just interactiveSessionUnitId) Nothing) files' let removals = [ tid | Target { targetId = tid } <- targets ] mapM_ GHC.removeTarget removals _ <- doLoadAndCollectInfo (Unadd $ length removals) LoadAllTargets @@ -2279,7 +2278,7 @@ setContextAfterLoad keep_ctxt (Just graph) = do -- We import the module with a * iff -- - it is interpreted, and -- - -XSafe is off (it doesn't allow *-imports) - let new_ctx | star_ok = [mkIIModule (GHC.moduleName m)] + let new_ctx | star_ok = [mkIIModule m] | otherwise = [mkIIDecl (GHC.moduleName m)] setContextKeepingPackageModules keep_ctxt new_ctx @@ -2699,7 +2698,7 @@ guessCurrentModule cmd = do imports <- GHC.getContext case imports of [] -> throwGhcException $ CmdLineError (':' : cmd ++ ": no current module") - IIModule m : _ -> GHC.findQualifiedModule NoPkgQual m + IIModule m : _ -> pure m IIDecl d : _ -> do pkgqual <- GHC.renameRawPkgQualM (unLoc $ ideclName d) (ideclPkgQual d) GHC.findQualifiedModule pkgqual (unLoc (ideclName d)) @@ -2829,8 +2828,9 @@ addModulesToContext starred unstarred = restoreContextOnFailure $ do addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m () addModulesToContext_ starred unstarred = do - mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred) - setGHCContextFromGHCiState + starredModules <- traverse lookupModuleName starred + mapM_ addII (map mkIIModule starredModules ++ map mkIIDecl unstarred) + setGHCContextFromGHCiState remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m () remModulesFromContext starred unstarred = do @@ -2896,9 +2896,9 @@ checkAdd ii = do dflags <- getDynFlags let safe = safeLanguageOn dflags case ii of - IIModule modname + IIModule mod | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell" - | otherwise -> wantInterpretedModuleName modname >> return () + | otherwise -> checkInterpretedModule mod >> return () IIDecl d -> do let modname = unLoc (ideclName d) @@ -2966,13 +2966,13 @@ getImplicitPreludeImports iidecls = do -- ----------------------------------------------------------------------------- -- Utils on InteractiveImport -mkIIModule :: ModuleName -> InteractiveImport +mkIIModule :: Module -> InteractiveImport mkIIModule = IIModule mkIIDecl :: ModuleName -> InteractiveImport mkIIDecl = IIDecl . simpleImportDecl -iiModules :: [InteractiveImport] -> [ModuleName] +iiModules :: [InteractiveImport] -> [Module] iiModules is = [m | IIModule m <- is] isIIModule :: InteractiveImport -> Bool @@ -2980,7 +2980,7 @@ isIIModule (IIModule _) = True isIIModule _ = False iiModuleName :: InteractiveImport -> ModuleName -iiModuleName (IIModule m) = m +iiModuleName (IIModule m) = moduleName m iiModuleName (IIDecl d) = unLoc (ideclName d) preludeModuleName :: ModuleName @@ -3239,22 +3239,30 @@ newDynFlags interactive_only minus_opts = do let oldFlags = HUG.homeUnitEnv_dflags homeUnitEnv -- TODO: perhaps write custom version of parseDynamicFlagsCmdLine which gives us more control over the errors and warnings (newFlags, _, _) <- DynFlags.parseDynamicFlagsCmdLine logger oldFlags lopts - let newFlags' = if uid == interactiveGhciUnitId - then wopt_unset newFlags Opt_WarnUnusedPackages - else newFlags + newFlags' <- + if uid == interactiveGhciUnitId || uid == interactiveSessionUnitId + then do + -- TODO: document this + let dflags1 = wopt_unset newFlags Opt_WarnUnusedPackages + if uid == interactiveGhciUnitId + then + GHC.normaliseInteractiveDynFlags logger dflags1 + else + pure dflags1 + else + pure newFlags pure (uid, oldFlags, newFlags') must_reload <- GHC.updateProgramDynFlags True updates -- update and check interactive dynflags -- TODO: document the relation ship between the interactive unit and in the interactive context icdflags <- hsc_dflags <$> GHC.getSession - GHC.setInteractiveDynFlags icdflags + modifySessionM (GHC.initialiseInteractiveDynFlags icdflags) -- if the package flags changed, reset the context and link -- the new packages. hsc_env <- GHC.getSession let dflags2 = hsc_dflags hsc_env - let interp = hscInterp hsc_env when must_reload $ do when (verbosity dflags2 > 0) $ liftIO . putStrLn $ @@ -3263,30 +3271,41 @@ newDynFlags interactive_only minus_opts = do -- Clear caches and eventually defined breakpoints. (#1620) clearCaches - let units = concatMap (preloadUnits . HUG.homeUnitEnv_units) (Foldable.toList $ hsc_HUG hsc_env) - liftIO $ Loader.loadPackages interp hsc_env units - -- package flags changed, we can't re-use any of the old context - setContextAfterLoad False Nothing -- TODO: recheck whether this is necessary - - -- TODO extract into separate function - let ld0length = length $ ldInputs dflags0 - fmrk0length = length $ cmdlineFrameworks dflags0 - - newLdInputs = drop ld0length (ldInputs dflags2) - newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2) + reloadPackages hsc_env - dflags' = dflags2 { ldInputs = newLdInputs - , cmdlineFrameworks = newCLFrameworks - } - hsc_env' = hscSetFlags dflags' hsc_env - - when (not (null newLdInputs && null newCLFrameworks)) $ - liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env' + reloadLinkerOptions hsc_env dflags0 dflags2 idflags <- hsc_dflags <$> GHC.getSession installInteractivePrint (interactivePrint idflags) False return () +reloadPackages :: GhciMonad m => HscEnv -> m () +reloadPackages hsc_env = do + let + units = + concatMap (preloadUnits . HUG.homeUnitEnv_units) + (Foldable.toList $ hsc_HUG hsc_env) + liftIO $ Loader.loadPackages (hscInterp hsc_env) hsc_env units + -- package flags changed, we can't re-use any of the old context + setContextAfterLoad False Nothing + +reloadLinkerOptions :: MonadIO m => HscEnv -> DynFlags -> DynFlags -> m () +reloadLinkerOptions hsc_env old_flags new_flags = do + let + + ld0length = length $ ldInputs old_flags + fmrk0length = length $ cmdlineFrameworks old_flags + + newLdInputs = drop ld0length (ldInputs new_flags) + newCLFrameworks = drop fmrk0length (cmdlineFrameworks new_flags) + + dflags' = new_flags { ldInputs = newLdInputs + , cmdlineFrameworks = newCLFrameworks + } + hsc_env' = hscSetFlags dflags' hsc_env + + when (not (null newLdInputs && null newCLFrameworks)) $ + liftIO $ Loader.loadCmdLineLibs (hscInterp hsc_env') hsc_env' unknownFlagsErr :: GhciMonad m => [String] -> m () unknownFlagsErr fs = mapM_ (\f -> reportError (GhciUnknownFlag f (suggestions f))) fs @@ -3428,7 +3447,7 @@ showImports = do trans_ctx = transient_ctx st show_one (IIModule star_m) - = ":module +*" ++ moduleNameString star_m + = ":module +*" ++ moduleNameString (moduleName star_m) show_one (IIDecl imp) = showPpr dflags imp prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx) @@ -3734,11 +3753,11 @@ completeBreakpoint = wrapCompleter spaces $ \w -> do -- #3000 filterM GHC.moduleIsInterpreted hmods -- Return all possible bids for a given Module - bidsByModule :: GhciMonad m => [ModuleName] -> Module -> m [String] + bidsByModule :: GhciMonad m => [Module] -> Module -> m [String] bidsByModule nonquals mod = do (_, decls) <- getModBreak mod let bids = nub $ declPath <$> elems decls - pure $ case (moduleName mod) `elem` nonquals of + pure $ case mod `elem` nonquals of True -> bids False -> (combineModIdent (showModule mod)) <$> bids @@ -4143,8 +4162,7 @@ breakSwitch (arg1:rest) | all isDigit arg1 = do imports <- GHC.getContext case iiModules imports of - (mn : _) -> do - md <- lookupModuleName mn + (md : _) -> do breakByModuleLine md (read arg1) rest [] -> do liftIO $ putStrLn "No modules are loaded with debugging support." @@ -4276,8 +4294,7 @@ list2 [arg] | all isDigit arg = do case iiModules imports of [] -> liftIO $ putStrLn "No module to list" (mn : _) -> do - md <- lookupModuleName mn - listModuleLine md (read arg) + listModuleLine mn (read arg) list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do md <- wantInterpretedModule arg1 listModuleLine md (read arg2) @@ -4536,7 +4553,17 @@ lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module -lookupQualifiedModuleName = GHC.lookupAnyQualifiedModule +lookupQualifiedModuleName qual modl = do + GHC.lookupAllQualifiedModuleNames qual modl >>= \case + [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found.")) + [m] -> pure m + ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous;\n" ++ errorMsg ms)) + where + str = moduleNameString modl + errorMsg ms = intercalate "\n" + [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) + | m <- ms + ] isMainUnitModule :: Module -> Bool isMainUnitModule m = GHC.moduleUnit m == mainUnit @@ -4586,15 +4613,19 @@ wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str) wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module wantInterpretedModuleName modname = do - modl <- lookupModuleName modname - let str = moduleNameString modname - hug <- hsc_HUG <$> GHC.getSession - unless (HUG.memberHugHomeModule modl hug) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) - is_interpreted <- GHC.moduleIsInterpreted modl - when (not is_interpreted) $ - throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) - return modl + modl <- lookupModuleName modname + checkInterpretedModule modl + +checkInterpretedModule :: GHC.GhcMonad m => Module -> m Module +checkInterpretedModule modl = do + let str = moduleNameString $ moduleName modl + hug <- hsc_HUG <$> GHC.getSession + unless (HUG.memberHugHomeModule modl hug) $ + throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module")) + is_interpreted <- GHC.moduleIsInterpreted modl + when (not is_interpreted) $ + throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first")) + return modl wantNameFromInterpretedModule :: GHC.GhcMonad m => (Name -> SDoc -> m ()) ===================================== testsuite/tests/ghci/linking/dyn/T3372.hs ===================================== @@ -60,7 +60,7 @@ load (f,mn) = do target <- GHC.guessTarget f Nothing Nothing GHC.liftIO $ putStrLn ("Load " ++ showSuccessFlag res) -- m <- GHC.findModule (GHC.mkModuleName mn) Nothing - GHC.setContext [GHC.IIModule $ GHC.moduleName $ m] + GHC.setContext [GHC.IIModule m] where showSuccessFlag GHC.Succeeded = "succeeded" showSuccessFlag GHC.Failed = "failed" ===================================== testsuite/tests/ghci/prog018/prog018.stdout ===================================== @@ -1,6 +1,6 @@ -[1 of 3] Compiling A ( A.hs, interpreted ) -[2 of 3] Compiling B ( B.hs, interpreted ) -[3 of 3] Compiling C ( C.hs, interpreted ) +[1 of 3] Compiling A ( A.hs, interpreted )[main] +[2 of 3] Compiling B ( B.hs, interpreted )[main] +[3 of 3] Compiling C ( C.hs, interpreted )[interactive-session] A.hs:5:1: warning: [GHC-62161] [-Wincomplete-patterns (in -Wextra)] Pattern match(es) are non-exhaustive In an equation for ‘incompletePattern’: @@ -18,7 +18,7 @@ C.hs:6:7: error: [GHC-88464] Variable not in scope: variableNotInScope :: () Failed, two modules loaded. -[3 of 3] Compiling C ( C.hs, interpreted ) +[3 of 3] Compiling C ( C.hs, interpreted )[interactive-session] C.hs:6:7: error: [GHC-88464] Variable not in scope: variableNotInScope :: () ===================================== testsuite/tests/ghci/scripts/T13869.stdout ===================================== @@ -1,14 +1,14 @@ -[1 of 1] Compiling T13869A ( T13869a.hs, interpreted ) +[1 of 1] Compiling T13869A ( T13869a.hs, interpreted )[interactive-session] Ok, one module loaded. Ok, one module reloaded. Ok, unloaded all modules. Ok, no modules to be reloaded. -[1 of 1] Compiling T13869A ( T13869a.hs, interpreted ) +[1 of 1] Compiling T13869A ( T13869a.hs, interpreted )[interactive-session] Ok, one module loaded. -[2 of 2] Compiling T13869B ( T13869b.hs, interpreted ) +[2 of 2] Compiling T13869B ( T13869b.hs, interpreted )[interactive-session] Ok, one module added. Ok, two modules reloaded. -[1 of 2] Compiling T13869A ( T13869a.hs, interpreted ) -[2 of 2] Compiling T13869B ( T13869b.hs, interpreted ) +[1 of 2] Compiling T13869A ( T13869a.hs, interpreted )[interactive-session] +[2 of 2] Compiling T13869B ( T13869b.hs, interpreted )[interactive-session] Ok, two modules loaded. Ok, one module unadded. ===================================== testsuite/tests/ghci/scripts/T13997.stdout ===================================== @@ -1,8 +1,8 @@ -[1 of 2] Compiling Bug2 ( Bug2.hs, Bug2.o ) -[2 of 2] Compiling Bug ( Bug.hs, Bug.o ) +[1 of 2] Compiling Bug2 ( Bug2.hs, Bug2.o )[main] +[2 of 2] Compiling Bug ( Bug.hs, Bug.o )[interactive-session] Ok, two modules loaded. -[1 of 3] Compiling New ( New.hs, New.o ) -[2 of 3] Compiling Bug2 ( Bug2.hs, Bug2.o ) [Source file changed] -[3 of 3] Compiling Bug ( Bug.hs, Bug.o ) [Bug2 changed] +[1 of 3] Compiling New ( New.hs, New.o )[main] +[2 of 3] Compiling Bug2 ( Bug2.hs, Bug2.o )[main] [Source file changed] +[3 of 3] Compiling Bug ( Bug.hs, Bug.o )[interactive-session] [Bug2 changed] Ok, three modules reloaded. True ===================================== testsuite/tests/ghci/scripts/T17669.stdout ===================================== @@ -1,6 +1,6 @@ -[1 of 1] Compiling T17669 ( T17669.hs, T17669.o ) +[1 of 1] Compiling T17669 ( T17669.hs, T17669.o )[interactive-session] Ok, one module loaded. this -[1 of 1] Compiling T17669 ( T17669.hs, T17669.o ) [Source file changed] +[1 of 1] Compiling T17669 ( T17669.hs, T17669.o )[interactive-session] [Source file changed] Ok, one module reloaded. that ===================================== testsuite/tests/ghci/scripts/T18330.stdout ===================================== @@ -1,9 +1,8 @@ -GHCi, version 9.3.20211019: https://www.haskell.org/ghc/ :? for help -ghci> [1 of 2] Compiling Main ( shell.hs, interpreted ) -[2 of 2] Linking shell +GHCi, version 9.13.20250422: https://www.haskell.org/ghc/ :? for help +ghci> [1 of 2] Compiling Main ( shell.hs, interpreted )[interactive-session] Ok, one module loaded. -ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted ) -Ok, one module loaded. -ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted ) [T18330.extra changed] +ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted )[interactive-session] Ok, one module loaded. +ghci> ghci> [1 of 1] Compiling T18330 ( T18330.hs, interpreted )[interactive-session] [T18330.extra changed] +Ok, one module reloaded. ghci> Leaving GHCi. ===================================== testsuite/tests/ghci/scripts/T1914.stdout ===================================== @@ -1,7 +1,7 @@ -[1 of 2] Compiling T1914B ( T1914B.hs, interpreted ) -[2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) +[1 of 2] Compiling T1914B ( T1914B.hs, interpreted )[main] +[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )[interactive-session] Ok, two modules loaded. -[2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) [Source file changed] +[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )[interactive-session] [Source file changed] Failed, one module reloaded. -[2 of 2] Compiling T1914A ( T1914A.hs, interpreted ) +[2 of 2] Compiling T1914A ( T1914A.hs, interpreted )[interactive-session] Ok, two modules reloaded. ===================================== testsuite/tests/ghci/scripts/T20217.stdout ===================================== @@ -1,5 +1,5 @@ -[1 of 3] Compiling T20217A[boot] ( T20217A.hs-boot, nothing ) -[2 of 3] Compiling T20217A ( T20217A.hs, nothing ) -[3 of 3] Compiling T20217 ( T20217.hs, nothing ) +[1 of 3] Compiling T20217A[boot] ( T20217A.hs-boot, nothing )[main] +[2 of 3] Compiling T20217A ( T20217A.hs, nothing )[main] +[3 of 3] Compiling T20217 ( T20217.hs, nothing )[interactive-session] Ok, three modules loaded. Ok, three modules reloaded. ===================================== testsuite/tests/ghci/scripts/T20587.stdout ===================================== @@ -1,4 +1,4 @@ -[1 of 1] Compiling B +[1 of 1] Compiling B[interactive-session] Ok, one module loaded. -[1 of 1] Compiling B [Source file changed] +[1 of 1] Compiling B[interactive-session] [Source file changed] Ok, one module reloaded. ===================================== testsuite/tests/ghci/scripts/T6105.stdout ===================================== @@ -1,4 +1,4 @@ -[1 of 1] Compiling T6105 ( T6105.hs, interpreted ) +[1 of 1] Compiling T6105 ( T6105.hs, interpreted )[interactive-session] Ok, one module loaded. -[1 of 1] Compiling T6105 ( T6105.hs, interpreted ) +[1 of 1] Compiling T6105 ( T6105.hs, interpreted )[interactive-session] Ok, one module reloaded. ===================================== testsuite/tests/ghci/scripts/T8042.stdout ===================================== @@ -1,9 +1,9 @@ -[1 of 3] Compiling T8042B ( T8042B.hs, T8042B.o ) -[2 of 3] Compiling T8042C ( T8042C.hs, interpreted ) -[3 of 3] Compiling T8042A ( T8042A.hs, interpreted ) +[1 of 3] Compiling T8042B ( T8042B.hs, T8042B.o )[main] +[2 of 3] Compiling T8042C ( T8042C.hs, interpreted )[main] +[3 of 3] Compiling T8042A ( T8042A.hs, interpreted )[interactive-session] Ok, three modules loaded. -[3 of 3] Compiling T8042A ( T8042A.hs, T8042A.o ) [Source file changed] +[3 of 3] Compiling T8042A ( T8042A.hs, T8042A.o )[interactive-session] [Source file changed] Ok, three modules reloaded. -[2 of 3] Compiling T8042C ( T8042C.hs, interpreted ) -[3 of 3] Compiling T8042A ( T8042A.hs, interpreted ) +[2 of 3] Compiling T8042C ( T8042C.hs, interpreted )[main] +[3 of 3] Compiling T8042A ( T8042A.hs, interpreted )[interactive-session] Ok, three modules loaded. ===================================== testsuite/tests/ghci/scripts/T8042recomp.stdout ===================================== @@ -1,6 +1,6 @@ -[1 of 2] Compiling T8042B ( T8042B.hs, T8042B.o ) -[2 of 2] Compiling T8042A ( T8042A.hs, T8042A.o ) +[1 of 2] Compiling T8042B ( T8042B.hs, T8042B.o )[main] +[2 of 2] Compiling T8042A ( T8042A.hs, T8042A.o )[interactive-session] Ok, two modules loaded. -[2 of 2] Compiling T8042A ( T8042A.hs, interpreted ) +[2 of 2] Compiling T8042A ( T8042A.hs, interpreted )[interactive-session] Ok, two modules loaded. Breakpoint 0 activated at T8042A.hs:1:44-56 ===================================== testsuite/tests/ghci/should_run/TopEnvIface.stdout ===================================== @@ -1,5 +1,5 @@ -[1 of 2] Compiling TopEnvIface2 ( TopEnvIface2.hs, interpreted ) -[2 of 2] Compiling TopEnvIface ( TopEnvIface.hs, interpreted ) +[1 of 2] Compiling TopEnvIface2 ( TopEnvIface2.hs, interpreted )[main] +[2 of 2] Compiling TopEnvIface ( TopEnvIface.hs, interpreted )[main] Ok, two modules loaded. "I should be printed twice" Leaving GHCi. View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d0a36c84651dee8ff3dd198a167b334... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d0a36c84651dee8ff3dd198a167b334... You're receiving this email because of your account on gitlab.haskell.org.
participants (1)
-
Hannes Siebenhandl (＠fendor)