Hannes Siebenhandl pushed to branch wip/fendor/no-load at Glasgow Haskell Compiler / GHC Commits: 166d218b by fendor at 2025-06-24T13:25:07+02:00 Teach `:reload` about multiple home units `:reload` needs to lookup the `ModuleName` and must not assume the given `ModuleName` is in the current `HomeUnit`. We add a new utility function which allows us to find a `HomeUnitModule` instead of a `Module`. Further, we introduce the `GhciCommandError` type which can be used to abort the execution of a GHCi command. This error is caught and printed in a human readable fashion. - - - - - 830a5ea7 by fendor at 2025-06-24T13:26:14+02:00 WIP - - - - - 18 changed files: - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Session.hs - compiler/GHC/Unit/Module/Graph.hs - ghc/GHCi/UI.hs - ghc/GHCi/UI/Exception.hs - ghc/GHCi/UI/Print.hs - testsuite/tests/ghc-e/should_fail/T18441fail5.stderr - testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr - testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr - + testsuite/tests/ghci/prog021/A.hs - + testsuite/tests/ghci/prog021/B.hs - + testsuite/tests/ghci/prog021/Makefile - + testsuite/tests/ghci/prog021/prog021.T - + testsuite/tests/ghci/prog021/prog021.script - + testsuite/tests/ghci/prog021/prog021.stderr - + testsuite/tests/ghci/prog021/prog021.stdout - testsuite/tests/ghci/scripts/ghci021.stderr Changes: ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -422,6 +422,8 @@ data DynFlags = DynFlags { -- | GHCi scripts specified by -ghci-script, in reverse order ghciScripts :: [String], + -- | Instruct GHCi to not load the targets immediately + ghciDontLoad :: Bool, -- Output style options pprUserLength :: Int, @@ -677,6 +679,7 @@ defaultDynFlags mySettings = customWarningCategories = completeWarningCategorySet, fatalCustomWarningCategories = emptyWarningCategorySet, ghciScripts = [], + ghciDontLoad = False, language = Nothing, safeHaskell = Sf_None, safeInfer = True, ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -116,6 +116,7 @@ import qualified Control.Monad.Catch as MC import Data.IORef import Data.Maybe import Data.List (sortOn, groupBy, sortBy) +import qualified Data.List as List import System.FilePath import Control.Monad.IO.Class @@ -343,8 +344,9 @@ warnUnknownModules hsc_env dflags mod_graph = do data LoadHowMuch = LoadAllTargets -- ^ Load all targets and its dependencies. - | LoadUpTo HomeUnitModule + | LoadUpTo [HomeUnitModule] -- ^ Load only the given module and its dependencies. + -- If empty, we load none of the targets | LoadDependenciesOf HomeUnitModule -- ^ Load only the dependencies of the given module, but not the module -- itself. @@ -517,16 +519,17 @@ countMods (ResolvedCycle ns) = length ns countMods (UnresolvedCycle ns) = length ns -- See Note [Upsweep] for a high-level description. -createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan] +createBuildPlan :: ModuleGraph -> Maybe [HomeUnitModule] -> [BuildPlan] createBuildPlan mod_graph maybe_top_mod = let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles - cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod + acyclic_mod_graph = topSortModuleGraph False mod_graph maybe_top_mod -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles. build_plan :: [BuildPlan] build_plan -- Fast path, if there are no boot modules just do a normal toposort - | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod + | isEmptyModuleEnv boot_modules = collapseAcyclic acyclic_mod_graph | otherwise = toBuildPlan cycle_mod_graph [] toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan] @@ -598,14 +601,17 @@ createBuildPlan mod_graph maybe_top_mod = collapseAcyclic [] = [] topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing - - in - - assertPpr (sum (map countMods build_plan) == lengthMG mod_graph) - (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMG mod_graph))]) + -- We need to use 'acyclic_mod_graph', since if 'maybe_top_mod' is 'Just', then the resulting module + -- graph is pruned, reducing the number of 'build_plan' elements. + -- We don't use the size of 'cycle_mod_graph', as it removes @.hi-boot@ modules. These are added + -- later in the processing. + assertPpr (sum (map countMods build_plan) == lengthMGWithSCC acyclic_mod_graph) + (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC acyclic_mod_graph))]) build_plan - + where + lengthMGWithSCC :: [SCC a] -> Int + lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0 -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally @@ -640,16 +646,20 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- check that the module given in HowMuch actually exists, otherwise -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m + let checkHowMuch (LoadUpTo ms) = checkMods ms + checkHowMuch (LoadDependenciesOf m) = checkMods [m] checkHowMuch _ = id - checkMod m and_then - | m `Set.member` all_home_mods = and_then - | otherwise = do - throwOneError $ mkPlainErrorMsgEnvelope noSrcSpan - $ GhcDriverMessage - $ DriverModuleNotFound (moduleUnit m) (moduleName m) + checkMods ms and_then = + case List.partition (`Set.member` all_home_mods) ms of + (_, []) -> and_then + (_, not_found_mods) -> do + let + mkModuleNotFoundError m = + mkPlainErrorMsgEnvelope noSrcSpan + $ GhcDriverMessage + $ DriverModuleNotFound (moduleUnit m) (moduleName m) + throwErrors $ mkMessages $ listToBag [mkModuleNotFoundError not_found | not_found <- not_found_mods] checkHowMuch how_much $ do @@ -662,12 +672,12 @@ load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do -- are definitely unnecessary, then emit a warning. warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps) - let maybe_top_mod = case how_much of + let maybe_top_mods = case how_much of LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m + LoadDependenciesOf m -> Just [m] _ -> Nothing - build_plan = createBuildPlan mod_graph maybe_top_mod + build_plan = createBuildPlan mod_graph maybe_top_mods cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache @@ -1301,7 +1311,7 @@ topSortModuleGraph :: Bool -- ^ Drop hi-boot nodes? (see below) -> ModuleGraph - -> Maybe HomeUnitModule + -> Maybe [HomeUnitModule] -- ^ Root module name. If @Nothing@, use the full graph. -> [SCC ModuleGraphNode] -- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes @@ -1351,7 +1361,7 @@ topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod = cmpModuleGraphNodes k1 k2 = compare (moduleGraphNodeRank k1) (moduleGraphNodeRank k2) `mappend` compare k2 k1 -topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode] +topSortModules :: Bool -> [ModuleGraphNode] -> Maybe [HomeUnitModule] -> [SCC ModuleGraphNode] topSortModules drop_hs_boot_nodes summaries mb_root_mod = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph where @@ -1360,17 +1370,20 @@ topSortModules drop_hs_boot_nodes summaries mb_root_mod initial_graph = case mb_root_mod of Nothing -> graph - Just (Module uid root_mod) -> + Just mods -> -- restrict the graph to just those modules reachable from -- the specified module. We do this by building a graph with -- the full set of nodes, and determining the reachable set from -- the specified node. - let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid - , graph `hasVertexG` node - = node - | otherwise - = throwGhcException (ProgramError "module does not exist") - in graphFromEdgedVerticesUniq (seq root (root:allReachable (graphReachability graph) root)) + let + findNodeForModule (Module uid root_mod) + | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid + , graph `hasVertexG` node + = seq node node + | otherwise + = throwGhcException (ProgramError "module does not exist") + roots = fmap findNodeForModule mods + in graphFromEdgedVerticesUniq (seq roots (roots ++ allReachableMany (graphReachability graph) roots)) newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a } deriving (Functor, Traversable, Foldable) ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -764,6 +764,9 @@ addHaddockOpts f d = d { haddockOptions = Just f} addGhciScript f d = d { ghciScripts = f : ghciScripts d} +setDontLoadGhci :: Bool -> DynP () +setDontLoadGhci f = upd $ \d -> d { ghciDontLoad = f } + setInteractivePrint f d = d { interactivePrint = Just f} ----------------------------------------------------------------------------- @@ -1344,6 +1347,8 @@ dynamic_flags_deps = [ , make_ord_flag defGhcFlag "haddock-opts" (hasArg addHaddockOpts) , make_ord_flag defGhcFlag "hpcdir" (SepArg setOptHpcDir) , make_ord_flag defGhciFlag "ghci-script" (hasArg addGhciScript) + , make_ord_flag defGhciFlag "ghci-no-load" (NoArg (setDontLoadGhci True)) + , make_ord_flag defGhciFlag "ghci-load" (NoArg (setDontLoadGhci False)) , make_ord_flag defGhciFlag "interactive-print" (hasArg setInteractivePrint) , make_ord_flag defGhcFlag "ticky-allocd" (NoArg (setGeneralFlag Opt_Ticky_Allocd)) ===================================== compiler/GHC/Unit/Module/Graph.hs ===================================== @@ -67,6 +67,7 @@ module GHC.Unit.Module.Graph , mapMG, mgMapM , mgModSummaries , mgLookupModule + , mgLookupModuleName , mgHasHoles , showModMsg @@ -523,6 +524,17 @@ mgLookupModule ModuleGraph{..} m = listToMaybe $ mapMaybe go mg_mss = Just ms go _ = Nothing +-- | +-- TODO @fendor: Docs +mgLookupModuleName :: ModuleGraph -> ModuleName -> [ModuleNodeInfo] +mgLookupModuleName ModuleGraph{..} m = mapMaybe go mg_mss + where + go (ModuleNode _ ms) + | NotBoot <- isBootModuleNodeInfo ms + , moduleName (moduleNodeInfoModule ms) == m + = Just ms + go _ = Nothing + mgMember :: ModuleGraph -> NodeKey -> Bool mgMember graph k = isJust $ snd (mg_graph graph) k ===================================== ghc/GHCi/UI.hs ===================================== @@ -948,7 +948,7 @@ runGHCi paths maybe_exprs = do -- immediately rather than going on to evaluate the expression. when (not (null paths)) $ do ok <- ghciHandle (\e -> do showException e; return Failed) $ - loadModule paths + initialLoadModule paths when (isJust maybe_exprs && failed ok) $ liftIO (exitWith (ExitFailure 1)) @@ -1302,7 +1302,8 @@ runOneCommand eh gCmd = do st <- getGHCiState ghciHandle (\e -> lift $ eh e >>= return . Just) $ handleSourceError printErrorAndFail $ - cmd_wrapper st $ doCommand c + handleGhciCommandError printErrorAndContinue $ + cmd_wrapper st $ doCommand c -- source error's are handled by runStmt -- is the handler necessary here? where @@ -1310,6 +1311,10 @@ runOneCommand eh gCmd = do printGhciException err return $ Just False -- Exit ghc -e, but not GHCi + printErrorAndContinue err = do + printGhciCommandException err + return $ Just False -- Exit ghc -e, but not GHCi + noSpace q = q >>= maybe (return Nothing) (\c -> case removeSpaces c of "" -> noSpace q @@ -2196,6 +2201,11 @@ loadModule fs = do (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs) either (liftIO . Exception.throwIO) return result +initialLoadModule :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag +initialLoadModule fs = do + (_, result) <- runAndPrintStats (const Nothing) (initialLoadModule' fs) + either (liftIO . Exception.throwIO) return result + -- | @:load@ command loadModule_ :: GhciMonad m => [FilePath] -> m () loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnitId)) (repeat Nothing)) @@ -2203,6 +2213,44 @@ loadModule_ fs = void $ loadModule (zip3 fs (repeat (Just interactiveSessionUnit loadModuleDefer :: GhciMonad m => [FilePath] -> m () loadModuleDefer = wrapDeferTypeErrors . loadModule_ +initialLoadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag +initialLoadModule' files = do + let (filenames, uids, phases) = unzip3 files + exp_filenames <- mapM expandPath filenames + let files' = zip3 exp_filenames uids phases + targets <- mapM (\(file, uid, phase) -> GHC.guessTarget file uid phase) files' + + -- NOTE: we used to do the dependency anal first, so that if it + -- fails we didn't throw away the current set of modules. This would + -- require some re-working of the GHC interface, so we'll leave it + -- as a ToDo for now. + + hsc_env <- GHC.getSession + let !dflags = hsc_dflags hsc_env + + let load_module = do + -- unload first + _ <- GHC.abandonAll + clearCaches + + GHC.setTargets targets + if ghciDontLoad dflags + then + doLoadAndCollectInfo Load (LoadUpTo []) + else + doLoadAndCollectInfo Load LoadAllTargets + + if gopt Opt_GhciLeakCheck dflags + then do + -- Grab references to the currently loaded modules so that we can see if + -- they leak. + leak_indicators <- liftIO $ getLeakIndicators hsc_env + success <- load_module + liftIO $ checkLeakIndicators dflags leak_indicators + return success + else + load_module + loadModule' :: GhciMonad m => [(FilePath, Maybe UnitId, Maybe Phase)] -> m SuccessFlag loadModule' files = do let (filenames, uids, phases) = unzip3 files @@ -2286,13 +2334,18 @@ unAddModule files = do -- | @:reload@ command reloadModule :: GhciMonad m => String -> m () reloadModule m = do - session <- GHC.getSession - let home_unit = homeUnitId (hsc_home_unit session) - ok <- doLoadAndCollectInfo Reload (loadTargets home_unit) + let mods = words m + loadTarget <- findLoadTargets mods + ok <- doLoadAndCollectInfo Reload loadTarget when (failed ok) failIfExprEvalMode where - loadTargets hu | null m = LoadAllTargets - | otherwise = LoadUpTo (mkModule hu (GHC.mkModuleName m)) + findLoadTargets modls + | null modls = + pure LoadAllTargets + | otherwise = do + mod_graph <- GHC.getModuleGraph + let mods = concatMap (fmap (fmap toUnitId . GHC.moduleNodeInfoModule) . GHC.mgLookupModuleName mod_graph) [GHC.mkModuleName modl | modl <- modls] + pure $ LoadUpTo mods reloadModuleDefer :: GhciMonad m => String -> m () reloadModuleDefer = wrapDeferTypeErrors . reloadModule @@ -4747,8 +4800,11 @@ showException se = Just other_ghc_ex -> putException (show other_ghc_ex) Nothing -> case fromException se of - Just UserInterrupt -> putException "Interrupted." - _ -> putException ("*** Exception: " ++ show se) + Just (GhciCommandError s) -> putException (show (GhciCommandError s)) + Nothing -> + case fromException se of + Just UserInterrupt -> putException "Interrupted." + _ -> putException ("*** Exception: " ++ show se) where putException = hPutStrLn stderr @@ -4798,15 +4854,22 @@ lookupModuleName mName = lookupQualifiedModuleName NoPkgQual mName lookupQualifiedModuleName :: GHC.GhcMonad m => PkgQual -> ModuleName -> m Module lookupQualifiedModuleName qual modl = do GHC.lookupAllQualifiedModuleNames qual modl >>= \case - [] -> throwGhcException (CmdLineError ("module '" ++ str ++ "' could not be found.")) + [] -> throwGhciCommandError (GhciModuleError $ GhciModuleNameNotFound modl) [m] -> pure m - ms -> throwGhcException (CmdLineError ("module name '" ++ str ++ "' is ambiguous:\n" ++ errorMsg ms)) + ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + +lookupHomeUnitModuleName :: GHC.GhcMonad m => ModuleName -> m HomeUnitModule +lookupHomeUnitModuleName modl = do + m <- GHC.lookupLoadedHomeModuleByModuleName modl >>= \case + Nothing -> throwGhciCommandError (GhciModuleError $ GhciNoLocalModuleName modl) + Just [m] -> pure m + Just ms -> throwGhciCommandError (GhciModuleError $ GhciAmbiguousModuleName modl ms) + + if unitIsDefinite (moduleUnit m) + then pure (fmap toUnitId m) + else throwGhcException (CmdLineError ("module '" ++ str ++ "' is not from a definite unit")) where str = moduleNameString modl - errorMsg ms = intercalate "\n" - [ "- " ++ unitIdString (toUnitId (moduleUnit m)) ++ ":" ++ moduleNameString (moduleName m) - | m <- ms - ] showModule :: Module -> String showModule = moduleNameString . moduleName ===================================== ghc/GHCi/UI/Exception.hs ===================================== @@ -5,7 +5,10 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} module GHCi.UI.Exception - ( GhciMessage(..) + ( GhciCommandError(..) + , throwGhciCommandError + , handleGhciCommandError + , GhciMessage(..) , GhciMessageOpts(..) , fromGhcOpts , toGhcHint @@ -29,19 +32,57 @@ import GHC.Tc.Errors.Ppr import GHC.Tc.Errors.Types import GHC.Types.Error.Codes +import GHC.Types.SrcLoc (interactiveSrcSpan) import GHC.TypeLits import GHC.Unit.State import GHC.Utils.Outputable +import GHC.Utils.Error import GHC.Generics import GHC.Types.Error import GHC.Types import qualified GHC +import Control.Exception +import Control.Monad.Catch as MC (MonadCatch, catch) +import Control.Monad.IO.Class import Data.List.NonEmpty (NonEmpty(..)) +-- | A 'GhciCommandError' are messages that caused the abortion of a GHCi command. +newtype GhciCommandError = GhciCommandError (Messages GhciMessage) + +instance Exception GhciCommandError + +instance Show GhciCommandError where + -- We implement 'Show' because it's required by the 'Exception' instance, but diagnostics + -- shouldn't be shown via the 'Show' typeclass, but rather rendered using the ppr functions. + -- This also explains why there is no 'Show' instance for a 'MsgEnvelope'. + show (GhciCommandError msgs) = + renderWithContext defaultSDocContext + . vcat + . pprMsgEnvelopeBagWithLocDefault + . getMessages + $ msgs + +-- | Perform the given action and call the exception handler if the action +-- throws a 'SourceError'. See 'SourceError' for more information. +handleGhciCommandError :: (MonadCatch m) => + (GhciCommandError -> m a) -- ^ exception handler + -> m a -- ^ action to perform + -> m a +handleGhciCommandError handler act = + MC.catch act (\(e :: GhciCommandError) -> handler e) + +throwGhciCommandError :: MonadIO m => GhciCommandMessage -> m a +throwGhciCommandError errorMessage = + liftIO + . throwIO + . GhciCommandError + . singleMessage + $ mkPlainErrorMsgEnvelope interactiveSrcSpan (GhciCommandMessage errorMessage) + -- | The Options passed to 'diagnosticMessage' -- in the 'Diagnostic' instance of 'GhciMessage'. data GhciMessageOpts = GhciMessageOpts @@ -257,6 +298,9 @@ data GhciModuleError | GhciNoResolvedModules | GhciNoModuleForName GHC.Name | GhciNoMatchingModuleExport + | GhciNoLocalModuleName !GHC.ModuleName + | GhciModuleNameNotFound !GHC.ModuleName + | GhciAmbiguousModuleName !GHC.ModuleName ![GHC.Module] deriving Generic instance Diagnostic GhciModuleError where @@ -278,6 +322,16 @@ instance Diagnostic GhciModuleError where -> "No module for" <+> ppr name GhciNoMatchingModuleExport -> "No matching export in any local modules." + GhciNoLocalModuleName modl + -> "Module" <+> quotes (ppr modl) <+> "cannot be found locally" + GhciModuleNameNotFound modl + -> "module" <+> quotes (ppr modl) <+> "could not be found." + GhciAmbiguousModuleName modl candidates + -> "Module name" <+> quotes (ppr modl) <+> "is ambiguous" $+$ + vcat + [ text "-" <+> ppr (GHC.moduleName m) <> colon <> ppr (GHC.moduleUnit m) + | m <- candidates + ] diagnosticReason = \case GhciModuleNotFound{} -> @@ -294,6 +348,12 @@ instance Diagnostic GhciModuleError where ErrorWithoutFlag GhciNoMatchingModuleExport{} -> ErrorWithoutFlag + GhciNoLocalModuleName{} -> + ErrorWithoutFlag + GhciModuleNameNotFound{} -> + ErrorWithoutFlag + GhciAmbiguousModuleName{} -> + ErrorWithoutFlag diagnosticHints = \case GhciModuleNotFound{} -> @@ -310,7 +370,12 @@ instance Diagnostic GhciModuleError where [] GhciNoMatchingModuleExport{} -> [] - + GhciNoLocalModuleName{} -> + [] + GhciModuleNameNotFound{} -> + [] + GhciAmbiguousModuleName{} -> + [] diagnosticCode = constructorCode @GHCi -- | A Diagnostic emitted by GHCi while executing a command @@ -487,6 +552,9 @@ type family GhciDiagnosticCode c = n | n -> c where GhciDiagnosticCode "GhciNoModuleForName" = 21847 GhciDiagnosticCode "GhciNoMatchingModuleExport" = 59723 GhciDiagnosticCode "GhciArgumentParseError" = 35671 + GhciDiagnosticCode "GhciNoLocalModuleName" = 81235 + GhciDiagnosticCode "GhciModuleNameNotFound" = 40475 + GhciDiagnosticCode "GhciAmbiguousModuleName" = 59019 type GhciConRecursInto :: Symbol -> Maybe Type type family GhciConRecursInto con where ===================================== ghc/GHCi/UI/Print.hs ===================================== @@ -5,6 +5,7 @@ module GHCi.UI.Print , printForUserPartWay , printError , printGhciException + , printGhciCommandException ) where import qualified GHC @@ -64,7 +65,7 @@ printForUserPartWay doc = do -- | pretty-print a 'GhciCommandMessage' printError :: GhcMonad m => GhciCommandMessage -> m () printError err = - let errEnvelope = mkPlainErrorMsgEnvelope (UnhelpfulSpan UnhelpfulInteractive) err + let errEnvelope = mkPlainErrorMsgEnvelope interactiveSrcSpan err in printError' (const NoDiagnosticOpts) (singleMessage errEnvelope) -- | Print the all diagnostics in a 'SourceError'. Specialised for GHCi error reporting @@ -72,6 +73,9 @@ printError err = printGhciException :: GhcMonad m => SourceError -> m () printGhciException err = printError' initGhciPrintConfig (GhciGhcMessage <$> (srcErrorMessages err)) +printGhciCommandException :: GhcMonad m => GhciCommandError -> m () +printGhciCommandException (GhciCommandError errs) = printError' initGhciPrintConfig errs + printError' :: (GhcMonad m, Diagnostic a) => (DynFlags -> DiagnosticOpts a) -> Messages a -> m () printError' get_config err = do dflags <- getDynFlags ===================================== testsuite/tests/ghc-e/should_fail/T18441fail5.stderr ===================================== @@ -1,4 +1,4 @@ -<no location info>: error: [GHC-82272] - module ‘Abcde’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘Abcde’ cannot be found locally 1 ===================================== testsuite/tests/ghci/prog-mhu003/prog-mhu003.stderr ===================================== @@ -1,9 +1,15 @@ -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo -module name 'Foo' is ambiguous: -- b-0.0.0:Foo -- d-0.0.0:Foo +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + +<interactive>: error: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:b-0.0.0 + - Foo:d-0.0.0 + ===================================== testsuite/tests/ghci/prog-mhu004/prog-mhu004a.stderr ===================================== @@ -1,9 +1,14 @@ -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo -module name 'Foo' is ambiguous: -- a-0.0.0:Foo -- b-0.0.0:Foo +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 + +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 + +<interactive>: [GHCi-59019] + Module name ‘Foo’ is ambiguous + - Foo:a-0.0.0 + - Foo:b-0.0.0 ===================================== testsuite/tests/ghci/prog021/A.hs ===================================== @@ -0,0 +1,5 @@ +module A (f) where + +f x = [x] + +g x = Just x ===================================== testsuite/tests/ghci/prog021/B.hs ===================================== @@ -0,0 +1,5 @@ +module B where + +import A + +h = f ===================================== testsuite/tests/ghci/prog021/Makefile ===================================== @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk ===================================== testsuite/tests/ghci/prog021/prog021.T ===================================== @@ -0,0 +1,6 @@ +test('prog021', + [req_interp, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + extra_files(['A.hs', 'B.hs', 'prog021.script']) + ], + ghci_script, ['prog021.script']) ===================================== testsuite/tests/ghci/prog021/prog021.script ===================================== @@ -0,0 +1,15 @@ +-- Loads all targets +:load A B +:m + A B +f 5 +g 5 +h 5 +-- Load only one target +:reload A +:m A +putStrLn "B is not loaded, we can't add it to the context" +:m + B +f 5 +putStrLn "`g` and `h` are not in scope" +g 5 +h 5 ===================================== testsuite/tests/ghci/prog021/prog021.stderr ===================================== @@ -0,0 +1,10 @@ +<no location info>: error: [GHC-35235] + Could not find module ‘B’. + It is not a module in the current program, or in any known package. + +<interactive>:14:1: error: [GHC-88464] + Variable not in scope: g :: t0 -> t + +<interactive>:15:1: error: [GHC-88464] + Variable not in scope: h :: t0 -> t + ===================================== testsuite/tests/ghci/prog021/prog021.stdout ===================================== @@ -0,0 +1,6 @@ +[5] +Just 5 +[5] +B is not loaded, we can't add it to the context +[5] +`g` and `h` are not in scope ===================================== testsuite/tests/ghci/scripts/ghci021.stderr ===================================== @@ -1,3 +1,3 @@ -<no location info>: error: [GHC-82272] - module ‘ThisDoesNotExist’ cannot be found locally +<interactive>: error: [GHCi-81235] + Module ‘ThisDoesNotExist’ cannot be found locally View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d18f16873f9c0c13ca85951c9753000... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d18f16873f9c0c13ca85951c9753000... You're receiving this email because of your account on gitlab.haskell.org.