diff options
Diffstat (limited to 'compiler/GHC')
27 files changed, 276 insertions, 151 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs index bb192a3278..e299eb9171 100644 --- a/compiler/GHC/Core/Lint.hs +++ b/compiler/GHC/Core/Lint.hs @@ -321,7 +321,7 @@ data EndPassConfig = EndPassConfig , ep_lintPassResult :: !(Maybe LintPassResultConfig) -- ^ Whether we should lint the result of this pass. - , ep_printUnqual :: !PrintUnqualified + , ep_namePprCtx :: !NamePprCtx , ep_dumpFlag :: !(Maybe DumpFlag) @@ -336,7 +336,7 @@ endPassIO :: Logger -> IO () -- Used by the IO-is CorePrep too endPassIO logger cfg binds rules - = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_printUnqual cfg) mb_flag + = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_namePprCtx cfg) mb_flag (renderWithContext defaultSDocContext (ep_prettyPass cfg)) (ep_passDetails cfg) binds rules ; for_ (ep_lintPassResult cfg) $ \lp_cfg -> @@ -350,16 +350,16 @@ endPassIO logger cfg binds rules dumpPassResult :: Logger -> Bool -- dump core sizes? - -> PrintUnqualified + -> NamePprCtx -> Maybe DumpFlag -- Just df => show details in a file whose -- name is specified by df -> String -- Header -> SDoc -- Extra info to appear after header -> CoreProgram -> [CoreRule] -> IO () -dumpPassResult logger dump_core_sizes unqual mb_flag hdr extra_info binds rules +dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds rules = do { forM_ mb_flag $ \flag -> do - logDumpFile logger (mkDumpStyle unqual) flag hdr FormatCore dump_doc + logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr FormatCore dump_doc -- Report result size -- This has the side effect of forcing the intermediate to be evaluated diff --git a/compiler/GHC/Core/Opt/Monad.hs b/compiler/GHC/Core/Opt/Monad.hs index 6f520cfcfd..d38f3e6c59 100644 --- a/compiler/GHC/Core/Opt/Monad.hs +++ b/compiler/GHC/Core/Opt/Monad.hs @@ -21,7 +21,7 @@ module GHC.Core.Opt.Monad ( getDynFlags, getPackageFamInstEnv, getInteractiveContext, getUniqMask, - getPrintUnqualified, getSrcSpanM, + getNamePprCtx, getSrcSpanM, -- ** Writing to the monad addSimplCount, @@ -114,7 +114,7 @@ data CoreReader = CoreReader { cr_hsc_env :: HscEnv, cr_rule_base :: RuleBase, -- Home package table rules cr_module :: Module, - cr_print_unqual :: PrintUnqualified, + cr_name_ppr_ctx :: NamePprCtx, cr_loc :: SrcSpan, -- Use this for log/error messages so they -- are at least tagged with the right source file cr_uniq_mask :: !Char -- Mask for creating unique values @@ -178,18 +178,18 @@ runCoreM :: HscEnv -> RuleBase -> Char -- ^ Mask -> Module - -> PrintUnqualified + -> NamePprCtx -> SrcSpan -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base mask mod print_unqual loc m +runCoreM hsc_env rule_base mask mod name_ppr_ctx loc m = liftM extract $ runIOEnv reader $ unCoreM m where reader = CoreReader { cr_hsc_env = hsc_env, cr_rule_base = rule_base, cr_module = mod, - cr_print_unqual = print_unqual, + cr_name_ppr_ctx = name_ppr_ctx, cr_loc = loc, cr_uniq_mask = mask } @@ -252,8 +252,8 @@ initRuleEnv guts getExternalRuleBase :: CoreM RuleBase getExternalRuleBase = eps_rule_base <$> get_eps -getPrintUnqualified :: CoreM PrintUnqualified -getPrintUnqualified = read cr_print_unqual +getNamePprCtx :: CoreM NamePprCtx +getNamePprCtx = read cr_name_ppr_ctx getSrcSpanM :: CoreM SrcSpan getSrcSpanM = read cr_loc @@ -360,14 +360,14 @@ msg :: MessageClass -> SDoc -> CoreM () msg msg_class doc = do logger <- getLogger loc <- getSrcSpanM - unqual <- getPrintUnqualified + name_ppr_ctx <- getNamePprCtx let sty = case msg_class of MCDiagnostic _ _ _ -> err_sty MCDump -> dump_sty _ -> user_sty - err_sty = mkErrStyle unqual - user_sty = mkUserStyle unqual AllTheWay - dump_sty = mkDumpStyle unqual + err_sty = mkErrStyle name_ppr_ctx + user_sty = mkUserStyle name_ppr_ctx AllTheWay + dump_sty = mkDumpStyle name_ppr_ctx liftIO $ logMsg logger msg_class loc (withPprStyle sty doc) -- | Output a String message to the screen diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs index c7834a0b31..8be830dbeb 100644 --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -81,7 +81,7 @@ core2core hsc_env guts@(ModGuts { mg_module = mod uniq_mask = 's' ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod - print_unqual loc $ + name_ppr_ctx loc $ do { hsc_env' <- getHscEnv ; all_passes <- withPlugins (hsc_plugins hsc_env') installCoreToDos @@ -101,7 +101,8 @@ core2core hsc_env guts@(ModGuts { mg_module = mod home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod , gwib_isBoot = NotBoot }) hpt_rule_base = mkRuleBase home_pkg_rules - print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env + name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env + ptc = initPromotionTickContext dflags -- mod: get the module out of the current HscEnv so we can retrieve it from the monad. -- This is very convienent for the users of the monad (e.g. plugins do not have to -- consume the ModGuts to find the module) but somewhat ugly because mg_module may @@ -488,10 +489,15 @@ doCorePass pass guts = do let fam_envs = (p_fam_env, mg_fam_inst_env guts) let updateBinds f = return $ guts { mg_binds = f (mg_binds guts) } let updateBindsM f = f (mg_binds guts) >>= \b' -> return $ guts { mg_binds = b' } + let name_ppr_ctx = + mkNamePprCtx + (initPromotionTickContext dflags) + (hsc_unit_env hsc_env) + (mg_rdr_env guts) case pass of CoreDoSimplify opts -> {-# SCC "Simplify" #-} - liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) opts guts + liftIOWithCount $ simplifyPgm logger (hsc_unit_env hsc_env) name_ppr_ctx opts guts CoreCSE -> {-# SCC "CommonSubExpr" #-} updateBinds cseProgram diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs index 0c8ec92f6c..0cc6d984e5 100644 --- a/compiler/GHC/Core/Opt/Simplify.hs +++ b/compiler/GHC/Core/Opt/Simplify.hs @@ -39,7 +39,6 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Tickish import GHC.Types.Unique.FM -import GHC.Types.Name.Ppr import Control.Monad import Data.Foldable ( for_ ) @@ -140,13 +139,13 @@ data SimplifyOpts = SimplifyOpts simplifyPgm :: Logger -> UnitEnv + -> NamePprCtx -- For dumping -> SimplifyOpts -> ModGuts -> IO (SimplCount, ModGuts) -- New bindings -simplifyPgm logger unit_env opts +simplifyPgm logger unit_env name_ppr_ctx opts guts@(ModGuts { mg_module = this_mod - , mg_rdr_env = rdr_env , mg_binds = binds, mg_rules = local_rules , mg_fam_inst_env = fam_inst_env }) = do { (termination_msg, it_count, counts_out, guts') @@ -168,7 +167,6 @@ simplifyPgm logger unit_env opts mode = so_mode opts max_iterations = so_iterations opts top_env_cfg = so_top_env_cfg opts - print_unqual = mkPrintUnqualified unit_env rdr_env active_rule = activeRule mode active_unf = activeUnfolding mode -- Note the bang in !guts_no_binds. If you don't force `guts_no_binds` @@ -275,7 +273,7 @@ simplifyPgm logger unit_env opts let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ; -- Dump the result of this iteration - dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ; + dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts1 binds2 rules1 ; for_ (so_pass_result_cfg opts) $ \pass_result_cfg -> lintPassResult logger pass_result_cfg binds2 ; @@ -292,10 +290,10 @@ simplifyPgm logger unit_env opts totalise = foldr (\c acc -> acc `plusSimplCount` c) (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats) -dump_end_iteration :: Logger -> Bool -> PrintUnqualified -> Int +dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int -> SimplCount -> CoreProgram -> [CoreRule] -> IO () -dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules - = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules +dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts binds rules + = dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr pp_counts binds rules where mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations | otherwise = Nothing diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 2088de341f..2a26363c7b 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -2907,11 +2907,15 @@ tcFlavourIsOpen TypeSynonymFlavour = False pprPromotionQuote :: TyCon -> SDoc -- Promoted data constructors already have a tick in their OccName -pprPromotionQuote tc - -- Always quote promoted DataCons in types, unless they come - -- from "type data" declarations. - | isDataKindsPromotedDataCon tc = char '\'' - | otherwise = empty +pprPromotionQuote tc = + getPprStyle $ \sty -> + let + name = getOccName tc + ticked = isDataKindsPromotedDataCon tc && promTick sty (PromotedItemDataCon name) + in + if ticked + then char '\'' + else empty instance NamedThing TyCon where getName = tyConName diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs index cf94e0cf1d..042d0fe021 100644 --- a/compiler/GHC/Driver/Backpack.hs +++ b/compiler/GHC/Driver/Backpack.hs @@ -597,7 +597,9 @@ backpackStyle = mkUserStyle (QueryQualify neverQualifyNames alwaysQualifyModules - neverQualifyPackages) AllTheWay + neverQualifyPackages + alwaysPrintPromTick) + AllTheWay -- | Message when we initially process a Backpack unit. msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () diff --git a/compiler/GHC/Driver/Config/Core/Lint.hs b/compiler/GHC/Driver/Config/Core/Lint.hs index 8ea716a36c..533f029c7b 100644 --- a/compiler/GHC/Driver/Config/Core/Lint.hs +++ b/compiler/GHC/Driver/Config/Core/Lint.hs @@ -37,18 +37,18 @@ before and after core passes, and do Core Lint when necessary. endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM () endPass pass binds rules = do { hsc_env <- getHscEnv - ; print_unqual <- getPrintUnqualified + ; name_ppr_ctx <- getNamePprCtx ; liftIO $ endPassHscEnvIO hsc_env - print_unqual pass binds rules + name_ppr_ctx pass binds rules } -endPassHscEnvIO :: HscEnv -> PrintUnqualified +endPassHscEnvIO :: HscEnv -> NamePprCtx -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -endPassHscEnvIO hsc_env print_unqual pass binds rules +endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules = do { let dflags = hsc_dflags hsc_env ; endPassIO (hsc_logger hsc_env) - (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) print_unqual pass) + (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) name_ppr_ctx pass) binds rules } @@ -62,13 +62,13 @@ lintCoreBindings dflags coreToDo vars -- binds , l_vars = vars } -initEndPassConfig :: DynFlags -> [Var] -> PrintUnqualified -> CoreToDo -> EndPassConfig -initEndPassConfig dflags extra_vars print_unqual pass = EndPassConfig +initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig +initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags) , ep_lintPassResult = if gopt Opt_DoCoreLinting dflags then Just $ initLintPassResultConfig dflags extra_vars pass else Nothing - , ep_printUnqual = print_unqual + , ep_namePprCtx = name_ppr_ctx , ep_dumpFlag = coreDumpFlag pass , ep_prettyPass = ppr pass , ep_passDetails = pprPassDetails pass diff --git a/compiler/GHC/Driver/Errors.hs b/compiler/GHC/Driver/Errors.hs index 024820202d..dd6834046b 100644 --- a/compiler/GHC/Driver/Errors.hs +++ b/compiler/GHC/Driver/Errors.hs @@ -19,15 +19,15 @@ import qualified GHC.Driver.CmdLine as CmdLine printMessages :: forall a . Diagnostic a => Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO () printMessages logger msg_opts opts msgs - = sequence_ [ let style = mkErrStyle unqual + = sequence_ [ let style = mkErrStyle name_ppr_ctx ctx = (diag_ppr_ctx opts) { sdocStyle = style } in logMsg logger (MCDiagnostic sev (diagnosticReason dia) (diagnosticCode dia)) s $ withPprStyle style (messageWithHints ctx dia) - | MsgEnvelope { errMsgSpan = s, + | MsgEnvelope { errMsgSpan = s, errMsgDiagnostic = dia, - errMsgSeverity = sev, - errMsgContext = unqual } <- sortMsgBag (Just opts) - (getMessages msgs) ] + errMsgSeverity = sev, + errMsgContext = name_ppr_ctx } + <- sortMsgBag (Just opts) (getMessages msgs) ] where messageWithHints :: Diagnostic a => SDocContext -> a -> SDoc messageWithHints ctx e = diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs index 592b997b0f..b1154b6398 100644 --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -219,6 +219,7 @@ data GeneralFlag | Opt_PrintUnicodeSyntax | Opt_PrintExpandedSynonyms | Opt_PrintPotentialInstances + | Opt_PrintRedundantPromotionTicks | Opt_PrintTypecheckerElaboration -- optimisation opts diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs index 5ca7487c27..4a22645223 100644 --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -2473,9 +2473,10 @@ hscTidy hsc_env guts = do -- post tidy pretty-printing and linting... let tidy_rules = md_rules details let all_tidy_binds = cg_binds cgguts - let print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts) + let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts) + ptc = initPromotionTickContext (hsc_dflags hsc_env) - endPassHscEnvIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules + endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules -- If the endPass didn't print the rules, but ddump-rules is -- on, print now diff --git a/compiler/GHC/Driver/Ppr.hs b/compiler/GHC/Driver/Ppr.hs index a61d1cae29..291be49065 100644 --- a/compiler/GHC/Driver/Ppr.hs +++ b/compiler/GHC/Driver/Ppr.hs @@ -26,14 +26,14 @@ showSDoc dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyl showPpr :: Outputable a => DynFlags -> a -> String showPpr dflags thing = showSDoc dflags (ppr thing) --- | Allows caller to specify the PrintUnqualified to use -showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String -showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContext dflags sty) doc' +-- | Allows caller to specify the NamePprCtx to use +showSDocForUser :: DynFlags -> UnitState -> NamePprCtx -> SDoc -> String +showSDocForUser dflags unit_state name_ppr_ctx doc = renderWithContext (initSDocContext dflags sty) doc' where - sty = mkUserStyle unqual AllTheWay + sty = mkUserStyle name_ppr_ctx AllTheWay doc' = pprWithUnitState unit_state doc -printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO () -printForUser dflags handle unqual depth doc +printForUser :: DynFlags -> Handle -> NamePprCtx -> Depth -> SDoc -> IO () +printForUser dflags handle name_ppr_ctx depth doc = printSDocLn ctx (PageMode False) handle doc - where ctx = initSDocContext dflags (mkUserStyle unqual depth) + where ctx = initSDocContext dflags (mkUserStyle name_ppr_ctx depth) diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs index 3e205402e9..168a204fbc 100644 --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -214,6 +214,7 @@ module GHC.Driver.Session ( -- * SDoc initSDocContext, initDefaultSDocContext, + initPromotionTickContext, ) where import GHC.Prelude @@ -3456,6 +3457,7 @@ fFlagsDeps = [ flagSpec "print-unicode-syntax" Opt_PrintUnicodeSyntax, flagSpec "print-expanded-synonyms" Opt_PrintExpandedSynonyms, flagSpec "print-potential-instances" Opt_PrintPotentialInstances, + flagSpec "print-redundant-promotion-ticks" Opt_PrintRedundantPromotionTicks, flagSpec "print-typechecker-elaboration" Opt_PrintTypecheckerElaboration, flagSpec "prof-cafs" Opt_AutoSccsOnIndividualCafs, flagSpec "prof-count-entries" Opt_ProfCountEntries, @@ -5042,6 +5044,13 @@ initSDocContext dflags style = SDC initDefaultSDocContext :: DynFlags -> SDocContext initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle +initPromotionTickContext :: DynFlags -> PromotionTickContext +initPromotionTickContext dflags = + PromTickCtx { + ptcListTuplePuns = True, + ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags + } + outputFile :: DynFlags -> Maybe String outputFile dflags | dynamicNow dflags = dynOutputFile_ dflags diff --git a/compiler/GHC/HsToCore.hs b/compiler/GHC/HsToCore.hs index 2ceb918fb1..05487e769e 100644 --- a/compiler/GHC/HsToCore.hs +++ b/compiler/GHC/HsToCore.hs @@ -146,7 +146,8 @@ deSugar hsc_env = do { let dflags = hsc_dflags hsc_env logger = hsc_logger hsc_env - print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env + ptc = initPromotionTickContext (hsc_dflags hsc_env) + name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env ; withTiming logger (text "Desugar"<+>brackets (ppr mod)) (const ()) $ @@ -212,7 +213,7 @@ deSugar hsc_env -- You might think it doesn't matter, but the simplifier brings all top-level -- things into the in-scope set before simplifying; so we get no unfolding for F#! - ; endPassHscEnvIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps + ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugar final_pgm rules_for_imps ; let simpl_opts = initSimpleOpts dflags ; let (ds_binds, ds_rules_for_imps, occ_anald_binds) = simpleOptPgm simpl_opts mod final_pgm rules_for_imps @@ -221,7 +222,7 @@ deSugar hsc_env ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis" FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps ) - ; endPassHscEnvIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps + ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugarOpt ds_binds ds_rules_for_imps ; let used_names = mkUsedNames tcg_env pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env)) diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs index 8723248f0a..17d9a3db94 100644 --- a/compiler/GHC/HsToCore/Monad.hs +++ b/compiler/GHC/HsToCore/Monad.hs @@ -23,7 +23,7 @@ module GHC.HsToCore.Monad ( newSysLocalsDs, newUniqueId, newFailLocalDs, newPredVarDs, getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA, - mkPrintUnqualifiedDs, + mkNamePprCtxDs, newUnique, UniqSupply, newUniqueSupply, getGhcModeDs, dsGetFamInstEnvs, @@ -199,7 +199,7 @@ fixDs = fixM type DsWarning = (SrcSpan, SDoc) -- Not quite the same as a WarnMsg, we have an SDoc here - -- and we'll do the print_unqual stuff later on to turn it + -- and we'll do the name_ppr_ctx stuff later on to turn it -- into a Doc. -- | Run a 'DsM' action inside the 'TcM' monad. @@ -237,12 +237,13 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env fam_inst_env = tcg_fam_inst_env tcg_env + ptc = initPromotionTickContext (hsc_dflags hsc_env) complete_matches = hptCompleteSigs hsc_env -- from the home package ++ tcg_complete_matches tcg_env -- from the current module ++ eps_complete_matches eps -- from imports -- re-use existing next_wrapper_num to ensure uniqueness next_wrapper_num_var = tcg_next_wrapper_num tcg_env - ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env + ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num_var complete_matches } @@ -272,6 +273,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds ; eps <- liftIO $ hscEPS hsc_env ; let unit_env = hsc_unit_env hsc_env type_env = typeEnvFromEntities ids tycons patsyns fam_insts + ptc = initPromotionTickContext (hsc_dflags hsc_env) complete_matches = hptCompleteSigs hsc_env -- from the home package ++ local_complete_matches -- from the current module ++ eps_complete_matches eps -- from imports @@ -281,7 +283,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds ids = concatMap bindsToIds binds envs = mkDsEnvs unit_env this_mod rdr_env type_env - fam_inst_env msg_var cc_st_var + fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches ; runDs hsc_env envs thing_inside } @@ -320,10 +322,11 @@ initTcDsForSolver thing_inside Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) } mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv + -> PromotionTickContext -> IORef (Messages DsMessage) -> IORef CostCentreState -> IORef (ModuleEnv Int) -> CompleteMatches -> (DsGblEnv, DsLclEnv) -mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var +mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var next_wrapper_num complete_matches = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs" -- Failing tests here are `ghci` and `T11985` if you get this wrong. @@ -340,7 +343,7 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var , ds_fam_inst_env = fam_inst_env , ds_gbl_rdr_env = rdr_env , ds_if_env = (if_genv, if_lenv) - , ds_unqual = mkPrintUnqualified unit_env rdr_env + , ds_name_ppr_ctx = mkNamePprCtx ptc unit_env rdr_env , ds_msgs = msg_var , ds_complete_matches = complete_matches , ds_cc_st = cc_st_var @@ -425,7 +428,7 @@ diagnosticDs dsMessage = do { env <- getGblEnv ; loc <- getSrcSpanDs ; !diag_opts <- initDiagOpts <$> getDynFlags - ; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage + ; let msg = mkMsgEnvelope diag_opts loc (ds_name_ppr_ctx env) dsMessage ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) } -- | Issue an error, but return the expression for (), so that we can continue @@ -443,8 +446,8 @@ failWithDs msg failDs :: DsM a failDs = failM -mkPrintUnqualifiedDs :: DsM PrintUnqualified -mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv +mkNamePprCtxDs :: DsM NamePprCtx +mkNamePprCtxDs = ds_name_ppr_ctx <$> getGblEnv instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where lookupThing = dsLookupGlobal diff --git a/compiler/GHC/HsToCore/Pmc/Utils.hs b/compiler/GHC/HsToCore/Pmc/Utils.hs index 9e0a40a5f3..a2a73067a9 100644 --- a/compiler/GHC/HsToCore/Pmc/Utils.hs +++ b/compiler/GHC/HsToCore/Pmc/Utils.hs @@ -35,8 +35,8 @@ import Control.Monad tracePm :: String -> SDoc -> DsM () tracePm herald doc = do logger <- getLogger - printer <- mkPrintUnqualifiedDs - liftIO $ putDumpFileMaybe' logger printer + name_ppr_ctx <- mkNamePprCtxDs + liftIO $ putDumpFileMaybe' logger name_ppr_ctx Opt_D_dump_ec_trace "" FormatText (text herald $$ (nest 2 doc)) {-# INLINE tracePm #-} -- see Note [INLINE conditional tracing utilities] diff --git a/compiler/GHC/HsToCore/Types.hs b/compiler/GHC/HsToCore/Types.hs index 59db2c9372..f1c1f98bc6 100644 --- a/compiler/GHC/HsToCore/Types.hs +++ b/compiler/GHC/HsToCore/Types.hs @@ -49,7 +49,7 @@ data DsGblEnv , ds_gbl_rdr_env :: GlobalRdrEnv -- needed *only* to know what newtype -- constructors are in scope during -- pattern-match satisfiability checking - , ds_unqual :: PrintUnqualified + , ds_name_ppr_ctx :: NamePprCtx , ds_msgs :: IORef (Messages DsMessage) -- Diagnostic messages , ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things diff --git a/compiler/GHC/Iface/Errors.hs b/compiler/GHC/Iface/Errors.hs index 6fecc023c5..743ce9a33a 100644 --- a/compiler/GHC/Iface/Errors.hs +++ b/compiler/GHC/Iface/Errors.hs @@ -46,7 +46,7 @@ hiModuleNameMismatchWarn requested_mod read_mod -- are the same withPprStyle (mkUserStyle alwaysQualify AllTheWay) $ -- we want the Modules below to be qualified with package names, - -- so reset the PrintUnqualified setting. + -- so reset the NamePprCtx setting. hsep [ text "Something is amiss; requested module " , ppr requested_mod , text "differs from name found in the interface file" diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs index 9bf2aaccc8..bf7ae8e005 100644 --- a/compiler/GHC/Iface/Load.hs +++ b/compiler/GHC/Iface/Load.hs @@ -1084,11 +1084,12 @@ showIface logger dflags unit_state name_cache filename = do qualifyImportedNames mod _ | mod == mi_module iface = NameUnqual | otherwise = NameNotInScope1 - print_unqual = QueryQualify qualifyImportedNames + name_ppr_ctx = QueryQualify qualifyImportedNames neverQualifyModules neverQualifyPackages + alwaysPrintPromTick logMsg logger MCDump noSrcSpan - $ withPprStyle (mkDumpStyle print_unqual) + $ withPprStyle (mkDumpStyle name_ppr_ctx) $ pprModIface unit_state iface -- | Show a ModIface but don't display details; suitable for ModIfaces stored in diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 3873b9133f..3e41a25132 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -1472,8 +1472,19 @@ pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc pprIfaceTyList ctxt_prec ty1 ty2 = case gather ty2 of (arg_tys, Nothing) - -> char '\'' <> brackets (spaceIfSingleQuote (fsep - (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys))))) + -> + sdocWithContext $ \ctx -> + let + items = ty1:arg_tys + eos = isListEmptyOrSingleton items + ticked = promTick (sdocStyle ctx) (PromotedItemListSyntax eos) + (preBracket, postBracket) = + if ticked + then (char '\'', spaceIfSingleQuote) + else (empty, id) + in + preBracket <> brackets (postBracket (fsep + (punctuate comma (map (ppr_ty topPrec) items)))) (arg_tys, Just tl) -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1) 2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]]) @@ -1864,11 +1875,21 @@ instance Outputable IfaceTyConInfo where pprPromotionQuote :: IfaceTyCon -> SDoc pprPromotionQuote tc = - pprPromotionQuoteI $ ifaceTyConIsPromoted $ ifaceTyConInfo tc + getPprStyle $ \sty -> + let + name = getOccName (ifaceTyConName tc) + ticked = + case ifaceTyConIsPromoted (ifaceTyConInfo tc) of + NotPromoted -> False + IsPromoted -> promTick sty (PromotedItemDataCon name) + in + if ticked + then char '\'' + else empty pprPromotionQuoteI :: PromotionFlag -> SDoc pprPromotionQuoteI NotPromoted = empty -pprPromotionQuoteI IsPromoted = char '\'' +pprPromotionQuoteI IsPromoted = char '\'' instance Outputable IfaceCoercion where ppr = pprIfaceCoercion diff --git a/compiler/GHC/Runtime/Context.hs b/compiler/GHC/Runtime/Context.hs index 3ddb886a0d..388ae69aea 100644 --- a/compiler/GHC/Runtime/Context.hs +++ b/compiler/GHC/Runtime/Context.hs @@ -10,7 +10,7 @@ module GHC.Runtime.Context , icReaderEnv , icInteractiveModule , icInScopeTTs - , icPrintUnqual + , icNamePprCtx ) where @@ -349,9 +349,10 @@ icInScopeTTs ictxt = filter in_scope_unqualified (ic_tythings ictxt) ] --- | Get the PrintUnqualified function based on the flags and this InteractiveContext -icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified -icPrintUnqual unit_env ictxt = mkPrintUnqualified unit_env (icReaderEnv ictxt) +-- | Get the NamePprCtx function based on the flags and this InteractiveContext +icNamePprCtx :: UnitEnv -> InteractiveContext -> NamePprCtx +icNamePprCtx unit_env ictxt = mkNamePprCtx ptc unit_env (icReaderEnv ictxt) + where ptc = initPromotionTickContext (ic_dflags ictxt) -- | extendInteractiveContext is called with new TyThings recently defined to update the -- InteractiveContext to include them. By putting new things first, unqualified diff --git a/compiler/GHC/Runtime/Debugger.hs b/compiler/GHC/Runtime/Debugger.hs index 59fd31dc5b..a89227aada 100644 --- a/compiler/GHC/Runtime/Debugger.hs +++ b/compiler/GHC/Runtime/Debugger.hs @@ -97,8 +97,8 @@ pprintClosureCommand bindThings force str = do printSDocs :: GhcMonad m => [SDoc] -> m () printSDocs sdocs = do logger <- getLogger - unqual <- GHC.getPrintUnqual - liftIO $ printOutputForUser logger unqual $ vcat sdocs + name_ppr_ctx <- GHC.getNamePprCtx + liftIO $ printOutputForUser logger name_ppr_ctx $ vcat sdocs -- Do the obtainTerm--bindSuspensions-computeSubstitution dance go :: GhcMonad m => Subst -> Id -> m (Subst, Term) diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs index 2c34b15f6f..04fd3b0656 100644 --- a/compiler/GHC/Tc/Utils/Monad.hs +++ b/compiler/GHC/Tc/Utils/Monad.hs @@ -46,7 +46,7 @@ module GHC.Tc.Utils.Monad( -- * Debugging traceTc, traceRn, traceOptTcRn, dumpOptTcRn, dumpTcRn, - getPrintUnqualified, + getNamePprCtx, printForUserTcRn, traceIf, traceOptIf, debugTc, @@ -847,11 +847,11 @@ dumpOptTcRn flag title fmt doc = dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn () dumpTcRn useUserStyle flag title fmt doc = do logger <- getLogger - printer <- getPrintUnqualified + name_ppr_ctx <- getNamePprCtx real_doc <- wrapDocLoc doc let sty = if useUserStyle - then mkUserStyle printer AllTheWay - else mkDumpStyle printer + then mkUserStyle name_ppr_ctx AllTheWay + else mkDumpStyle name_ppr_ctx liftIO $ logDumpFile logger sty flag title fmt real_doc -- | Add current location if -dppr-debug @@ -866,18 +866,19 @@ wrapDocLoc doc = do else return doc -getPrintUnqualified :: TcRn PrintUnqualified -getPrintUnqualified - = do { rdr_env <- getGlobalRdrEnv +getNamePprCtx :: TcRn NamePprCtx +getNamePprCtx + = do { ptc <- initPromotionTickContext <$> getDynFlags + ; rdr_env <- getGlobalRdrEnv ; hsc_env <- getTopEnv - ; return $ mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env } + ; return $ mkNamePprCtx ptc (hsc_unit_env hsc_env) rdr_env } -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn () printForUserTcRn doc = do logger <- getLogger - printer <- getPrintUnqualified - liftIO (printOutputForUser logger printer doc) + name_ppr_ctx <- getNamePprCtx + liftIO (printOutputForUser logger name_ppr_ctx doc) {- traceIf works in the TcRnIf monad, where no RdrEnv is @@ -1117,9 +1118,9 @@ add_long_err_at loc msg = mk_long_err_at loc msg >>= reportDiagnostic where mk_long_err_at :: SrcSpan -> TcRnMessageDetailed -> TcRn (MsgEnvelope TcRnMessage) mk_long_err_at loc msg - = do { printer <- getPrintUnqualified ; + = do { name_ppr_ctx <- getNamePprCtx ; unit_state <- hsc_units <$> getTopEnv ; - return $ mkErrorMsgEnvelope loc printer + return $ mkErrorMsgEnvelope loc name_ppr_ctx $ TcRnMessageWithInfo unit_state msg } @@ -1127,9 +1128,9 @@ mkTcRnMessage :: SrcSpan -> TcRnMessage -> TcRn (MsgEnvelope TcRnMessage) mkTcRnMessage loc msg - = do { printer <- getPrintUnqualified ; + = do { name_ppr_ctx <- getNamePprCtx ; diag_opts <- initDiagOpts <$> getDynFlags ; - return $ mkMsgEnvelope diag_opts loc printer msg } + return $ mkMsgEnvelope diag_opts loc name_ppr_ctx msg } reportDiagnostics :: [MsgEnvelope TcRnMessage] -> TcM () reportDiagnostics = mapM_ reportDiagnostic @@ -1613,12 +1614,12 @@ addDiagnosticTcM (env0, msg) addDetailedDiagnostic :: (ErrInfo -> TcRnMessage) -> TcM () addDetailedDiagnostic mkMsg = do loc <- getSrcSpanM - printer <- getPrintUnqualified + name_ppr_ctx <- getNamePprCtx !diag_opts <- initDiagOpts <$> getDynFlags env0 <- tcInitTidyEnv ctxt <- getErrCtxt err_info <- mkErrInfo env0 ctxt - reportDiagnostic (mkMsgEnvelope diag_opts loc printer (mkMsg (ErrInfo err_info empty))) + reportDiagnostic (mkMsgEnvelope diag_opts loc name_ppr_ctx (mkMsg (ErrInfo err_info empty))) addTcRnDiagnostic :: TcRnMessage -> TcM () addTcRnDiagnostic msg = do diff --git a/compiler/GHC/Types/Error.hs b/compiler/GHC/Types/Error.hs index 3bc7937df0..695072e632 100644 --- a/compiler/GHC/Types/Error.hs +++ b/compiler/GHC/Types/Error.hs @@ -351,7 +351,7 @@ instance Outputable DiagnosticReason where data MsgEnvelope e = MsgEnvelope { errMsgSpan :: SrcSpan -- ^ The SrcSpan is used for sorting errors into line-number order - , errMsgContext :: PrintUnqualified + , errMsgContext :: NamePprCtx , errMsgDiagnostic :: e , errMsgSeverity :: Severity } deriving (Functor, Foldable, Traversable) diff --git a/compiler/GHC/Types/Name/Ppr.hs b/compiler/GHC/Types/Name/Ppr.hs index 3a4dfdc018..2670b27cd9 100644 --- a/compiler/GHC/Types/Name/Ppr.hs +++ b/compiler/GHC/Types/Name/Ppr.hs @@ -1,7 +1,7 @@ module GHC.Types.Name.Ppr - ( mkPrintUnqualified + ( mkNamePprCtx , mkQualModule , mkQualPackage , pkgQual @@ -9,6 +9,7 @@ module GHC.Types.Name.Ppr where import GHC.Prelude +import GHC.Data.FastString import GHC.Unit import GHC.Unit.Env @@ -52,7 +53,7 @@ There's one further subtlety: in case (3), what if there are two things around, P1:M.T and P2:M.T? Then we don't want to print both of them as M.T! However only one of the modules P1:M and P2:M can be exposed (say P2), so we use M.T for that, and P1:M.T for the other one. -This is handled by the qual_mod component of PrintUnqualified, inside +This is handled by the qual_mod component of NamePprCtx, inside the (ppr mod) of case (3), in Name.pprModulePrefix Note [Printing unit ids] @@ -66,14 +67,19 @@ with some holes, we should try to give the user some more useful information. -- | Creates some functions that work out the best ways to format -- names for the user according to a set of heuristics. -mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified -mkPrintUnqualified unit_env env - = QueryQualify qual_name +mkNamePprCtx :: PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx +mkNamePprCtx ptc unit_env env + = QueryQualify + (mkQualName env) (mkQualModule unit_state home_unit) (mkQualPackage unit_state) + (mkPromTick ptc env) where unit_state = ue_units unit_env home_unit = ue_homeUnit unit_env + +mkQualName :: GlobalRdrEnv -> QueryQualifyName +mkQualName env = qual_name where qual_name mod occ | [gre] <- unqual_gres , right_name gre @@ -125,6 +131,35 @@ mkPrintUnqualified unit_env env -- "import M" would resolve unambiguously to P:M. (if P is the -- current package we can just assume it is unqualified). +mkPromTick :: PromotionTickContext -> GlobalRdrEnv -> QueryPromotionTick +mkPromTick ptc env + | ptcPrintRedundantPromTicks ptc = alwaysPrintPromTick + | otherwise = print_prom_tick + where + print_prom_tick (PromotedItemListSyntax (IsEmptyOrSingleton eos)) = + -- Ticked: '[], '[x] + -- Unticked: [x,y], [x,y,z], and so on + ptcListTuplePuns ptc && eos + print_prom_tick PromotedItemTupleSyntax = + ptcListTuplePuns ptc + print_prom_tick (PromotedItemDataCon occ) + | isPunnedDataConName occ -- '[], '(,), ''(,,) + = ptcListTuplePuns ptc + + | Just occ' <- promoteOccName occ + , [] <- lookupGRE_RdrName (mkRdrUnqual occ') env + = -- Could not find a corresponding type name in the environment, + -- so the data name is unambiguous. Promotion tick not needed. + False + | otherwise = True + +isPunnedDataConName :: OccName -> Bool +isPunnedDataConName occ = + isDataOcc occ && case unpackFS (occNameFS occ) of + '[':_ -> True + '(':_ -> True + _ -> False + {- Note [pretendNameIsInScopeForPpr] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ c.f. Note [pretendNameIsInScope] in GHC.Builtin.Names @@ -200,5 +235,5 @@ mkQualPackage pkgs uid -- | A function which only qualifies package names if necessary; but -- qualifies all other identifiers. -pkgQual :: UnitState -> PrintUnqualified +pkgQual :: UnitState -> NamePprCtx pkgQual pkgs = alwaysQualify { queryQualifyPackage = mkQualPackage pkgs } diff --git a/compiler/GHC/Utils/Error.hs b/compiler/GHC/Utils/Error.hs index def40ea728..8910dd4d38 100644 --- a/compiler/GHC/Utils/Error.hs +++ b/compiler/GHC/Utils/Error.hs @@ -141,12 +141,12 @@ mk_msg_envelope :: Diagnostic e => Severity -> SrcSpan - -> PrintUnqualified + -> NamePprCtx -> e -> MsgEnvelope e -mk_msg_envelope severity locn print_unqual err +mk_msg_envelope severity locn name_ppr_ctx err = MsgEnvelope { errMsgSpan = locn - , errMsgContext = print_unqual + , errMsgContext = name_ppr_ctx , errMsgDiagnostic = err , errMsgSeverity = severity } @@ -158,22 +158,22 @@ mkMsgEnvelope :: Diagnostic e => DiagOpts -> SrcSpan - -> PrintUnqualified + -> NamePprCtx -> e -> MsgEnvelope e -mkMsgEnvelope opts locn print_unqual err - = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn print_unqual err +mkMsgEnvelope opts locn name_ppr_ctx err + = mk_msg_envelope (diagReasonSeverity opts (diagnosticReason err)) locn name_ppr_ctx err -- | Wrap a 'Diagnostic' in a 'MsgEnvelope', recording its location. -- Precondition: the diagnostic is, in fact, an error. That is, -- @diagnosticReason msg == ErrorWithoutFlag@. mkErrorMsgEnvelope :: Diagnostic e => SrcSpan - -> PrintUnqualified + -> NamePprCtx -> e -> MsgEnvelope e -mkErrorMsgEnvelope locn unqual msg = - assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn unqual msg +mkErrorMsgEnvelope locn name_ppr_ctx msg = + assert (diagnosticReason msg == ErrorWithoutFlag) $ mk_msg_envelope SevError locn name_ppr_ctx msg -- | Variant that doesn't care about qualified/unqualified names. mkPlainMsgEnvelope :: Diagnostic e @@ -247,9 +247,9 @@ pprLocMsgEnvelope :: Diagnostic e => DiagnosticOpts e -> MsgEnvelope e -> SDoc pprLocMsgEnvelope opts (MsgEnvelope { errMsgSpan = s , errMsgDiagnostic = e , errMsgSeverity = sev - , errMsgContext = unqual }) + , errMsgContext = name_ppr_ctx }) = sdocWithContext $ \ctx -> - withErrStyle unqual $ + withErrStyle name_ppr_ctx $ mkLocMessage (MCDiagnostic sev (diagnosticReason e) (diagnosticCode e)) s @@ -430,13 +430,13 @@ debugTraceMsg logger val msg = putMsg :: Logger -> SDoc -> IO () putMsg logger msg = logInfo logger (withPprStyle defaultUserStyle msg) -printInfoForUser :: Logger -> PrintUnqualified -> SDoc -> IO () -printInfoForUser logger print_unqual msg - = logInfo logger (withUserStyle print_unqual AllTheWay msg) +printInfoForUser :: Logger -> NamePprCtx -> SDoc -> IO () +printInfoForUser logger name_ppr_ctx msg + = logInfo logger (withUserStyle name_ppr_ctx AllTheWay msg) -printOutputForUser :: Logger -> PrintUnqualified -> SDoc -> IO () -printOutputForUser logger print_unqual msg - = logOutput logger (withUserStyle print_unqual AllTheWay msg) +printOutputForUser :: Logger -> NamePprCtx -> SDoc -> IO () +printOutputForUser logger name_ppr_ctx msg + = logOutput logger (withUserStyle name_ppr_ctx AllTheWay msg) logInfo :: Logger -> SDoc -> IO () logInfo logger msg = logMsg logger MCInfo noSrcSpan msg diff --git a/compiler/GHC/Utils/Logger.hs b/compiler/GHC/Utils/Logger.hs index cb79b7320b..4603b42d7b 100644 --- a/compiler/GHC/Utils/Logger.hs +++ b/compiler/GHC/Utils/Logger.hs @@ -553,29 +553,29 @@ putDumpFileMaybe logger = putDumpFileMaybe' logger alwaysQualify -- | Dump if the given DumpFlag is set -- --- Unlike 'putDumpFileMaybe', has a PrintUnqualified argument +-- Unlike 'putDumpFileMaybe', has a NamePprCtx argument putDumpFileMaybe' :: Logger - -> PrintUnqualified + -> NamePprCtx -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () -putDumpFileMaybe' logger printer flag hdr fmt doc +putDumpFileMaybe' logger name_ppr_ctx flag hdr fmt doc = when (logHasDumpFlag logger flag) $ - logDumpFile' logger printer flag hdr fmt doc + logDumpFile' logger name_ppr_ctx flag hdr fmt doc {-# INLINE putDumpFileMaybe' #-} -- see Note [INLINE conditional tracing utilities] -logDumpFile' :: Logger -> PrintUnqualified -> DumpFlag +logDumpFile' :: Logger -> NamePprCtx -> DumpFlag -> String -> DumpFormat -> SDoc -> IO () {-# NOINLINE logDumpFile' #-} -- NOINLINE: Now we are past the conditional, into the "cold" path, -- don't inline, to reduce code size at the call site -- See Note [INLINE conditional tracing utilities] -logDumpFile' logger printer flag hdr fmt doc - = logDumpFile logger (mkDumpStyle printer) flag hdr fmt doc +logDumpFile' logger name_ppr_ctx flag hdr fmt doc + = logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr fmt doc -- | Ensure that a dump file is created even if it stays empty touchDumpFile :: Logger -> DumpFlag -> IO () diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index 09be4b1c2d..812edf15cd 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -86,12 +86,15 @@ module GHC.Utils.Outputable ( -- * Controlling the style in which output is printed BindingSite(..), - PprStyle(..), PrintUnqualified(..), - QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, + PprStyle(..), NamePprCtx(..), + QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, QueryPromotionTick, + PromotedItem(..), IsEmptyOrSingleton(..), isListEmptyOrSingleton, + PromotionTickContext(..), reallyAlwaysQualify, reallyAlwaysQualifyNames, alwaysQualify, alwaysQualifyNames, alwaysQualifyModules, neverQualify, neverQualifyNames, neverQualifyModules, alwaysQualifyPackages, neverQualifyPackages, + alwaysPrintPromTick, QualifyName(..), queryQual, sdocOption, updSDocContext, @@ -100,7 +103,7 @@ module GHC.Utils.Outputable ( getPprStyle, withPprStyle, setStyleColoured, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, dumpStyle, - qualName, qualModule, qualPackage, + qualName, qualModule, qualPackage, promTick, mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), withUserStyle, withErrStyle, @@ -163,14 +166,14 @@ import GHC.Exts (oneShot) -} data PprStyle - = PprUser PrintUnqualified Depth Coloured + = PprUser NamePprCtx Depth Coloured -- Pretty-print in a way that will make sense to the -- ordinary user; must be very close to Haskell -- syntax, etc. -- Assumes printing tidied code: non-system names are -- printed without uniques. - | PprDump PrintUnqualified + | PprDump NamePprCtx -- For -ddump-foo; less verbose than in ppr-debug mode, but more than PprUser -- Does not assume tidied code: non-external names -- are printed with uniques. @@ -193,10 +196,11 @@ data Coloured -- original names back to something the user understands. This is the -- purpose of the triple of functions that gets passed around -- when rendering 'SDoc'. -data PrintUnqualified = QueryQualify { +data NamePprCtx = QueryQualify { queryQualifyName :: QueryQualifyName, queryQualifyModule :: QueryQualifyModule, - queryQualifyPackage :: QueryQualifyPackage + queryQualifyPackage :: QueryQualifyPackage, + queryPromotionTick :: QueryPromotionTick } -- | Given a `Name`'s `Module` and `OccName`, decide whether and how to qualify @@ -211,6 +215,31 @@ type QueryQualifyModule = Module -> Bool -- the component id to disambiguate it. type QueryQualifyPackage = Unit -> Bool +-- | Given a promoted data constructor, +-- decide whether to print a tick to disambiguate the namespace. +type QueryPromotionTick = PromotedItem -> Bool + +-- | Flags that affect whether a promotion tick is printed. +data PromotionTickContext = + PromTickCtx { + ptcListTuplePuns :: !Bool, + ptcPrintRedundantPromTicks :: !Bool + } + +data PromotedItem = + PromotedItemListSyntax IsEmptyOrSingleton -- '[x] + | PromotedItemTupleSyntax -- '(x, y) + | PromotedItemDataCon OccName -- 'MkT + +newtype IsEmptyOrSingleton = IsEmptyOrSingleton Bool + +isListEmptyOrSingleton :: [a] -> IsEmptyOrSingleton +isListEmptyOrSingleton xs = + IsEmptyOrSingleton $ case xs of + [] -> True + [_] -> True + _ -> False + -- See Note [Printing original names] in GHC.Types.Name.Ppr data QualifyName -- Given P:M.T = NameUnqual -- It's in scope unqualified as "T" @@ -252,17 +281,23 @@ alwaysQualifyPackages _ = True neverQualifyPackages :: QueryQualifyPackage neverQualifyPackages _ = False -reallyAlwaysQualify, alwaysQualify, neverQualify :: PrintUnqualified +alwaysPrintPromTick :: QueryPromotionTick +alwaysPrintPromTick _ = True + +reallyAlwaysQualify, alwaysQualify, neverQualify :: NamePprCtx reallyAlwaysQualify = QueryQualify reallyAlwaysQualifyNames alwaysQualifyModules alwaysQualifyPackages + alwaysPrintPromTick alwaysQualify = QueryQualify alwaysQualifyNames alwaysQualifyModules alwaysQualifyPackages + alwaysPrintPromTick neverQualify = QueryQualify neverQualifyNames neverQualifyModules neverQualifyPackages + alwaysPrintPromTick defaultUserStyle :: PprStyle defaultUserStyle = mkUserStyle neverQualify AllTheWay @@ -271,31 +306,31 @@ defaultDumpStyle :: PprStyle -- Print without qualifiers to reduce verbosity, unless -dppr-debug defaultDumpStyle = PprDump neverQualify -mkDumpStyle :: PrintUnqualified -> PprStyle -mkDumpStyle print_unqual = PprDump print_unqual +mkDumpStyle :: NamePprCtx -> PprStyle +mkDumpStyle name_ppr_ctx = PprDump name_ppr_ctx --- | Default style for error messages, when we don't know PrintUnqualified +-- | Default style for error messages, when we don't know NamePprCtx -- It's a bit of a hack because it doesn't take into account what's in scope -- Only used for desugarer warnings, and typechecker errors in interface sigs defaultErrStyle :: PprStyle defaultErrStyle = mkErrStyle neverQualify -- | Style for printing error messages -mkErrStyle :: PrintUnqualified -> PprStyle -mkErrStyle unqual = mkUserStyle unqual DefaultDepth +mkErrStyle :: NamePprCtx -> PprStyle +mkErrStyle name_ppr_ctx = mkUserStyle name_ppr_ctx DefaultDepth cmdlineParserStyle :: PprStyle cmdlineParserStyle = mkUserStyle alwaysQualify AllTheWay -mkUserStyle :: PrintUnqualified -> Depth -> PprStyle -mkUserStyle unqual depth = PprUser unqual depth Uncoloured +mkUserStyle :: NamePprCtx -> Depth -> PprStyle +mkUserStyle name_ppr_ctx depth = PprUser name_ppr_ctx depth Uncoloured -withUserStyle :: PrintUnqualified -> Depth -> SDoc -> SDoc -withUserStyle unqual depth doc = withPprStyle (PprUser unqual depth Uncoloured) doc +withUserStyle :: NamePprCtx -> Depth -> SDoc -> SDoc +withUserStyle name_ppr_ctx depth doc = withPprStyle (PprUser name_ppr_ctx depth Uncoloured) doc -withErrStyle :: PrintUnqualified -> SDoc -> SDoc -withErrStyle unqual doc = - withPprStyle (mkErrStyle unqual) doc +withErrStyle :: NamePprCtx -> SDoc -> SDoc +withErrStyle name_ppr_ctx doc = + withPprStyle (mkErrStyle name_ppr_ctx) doc setStyleColoured :: Bool -> PprStyle -> PprStyle setStyleColoured col style = @@ -534,10 +569,16 @@ qualPackage (PprUser q _ _) m = queryQualifyPackage q m qualPackage (PprDump q) m = queryQualifyPackage q m qualPackage _other _m = True -queryQual :: PprStyle -> PrintUnqualified +promTick :: PprStyle -> QueryPromotionTick +promTick (PprUser q _ _) occ = queryPromotionTick q occ +promTick (PprDump q) occ = queryPromotionTick q occ +promTick _ _ = True + +queryQual :: PprStyle -> NamePprCtx queryQual s = QueryQualify (qualName s) (qualModule s) (qualPackage s) + (promTick s) codeStyle :: PprStyle -> Bool codeStyle PprCode = True |