warnPprTrace: pass separately the reasonwip/warn-ppr-trace

This makes it more similar to pprTrace, pprPanic etc.

30 files changed, 55 insertions, 50 deletions

diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index 26efd7a52b..743d27fc15 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -1113,7 +1113,7 @@ pprReg r = case r of
 
 pprAsPtrReg :: CmmReg -> SDoc
 pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
-  = warnPprTrace (gcp /= VGcPtr) (ppr n) $ char 'R' <> int n <> text ".p"
+  = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p"
 pprAsPtrReg other_reg = pprReg other_reg
 
 pprGlobalReg :: GlobalReg -> SDoc
diff --git a/compiler/GHC/Core/Coercion/Opt.hs b/compiler/GHC/Core/Coercion/Opt.hs
index 4be4441682..041be10e3b 100644
--- a/compiler/GHC/Core/Coercion/Opt.hs
+++ b/compiler/GHC/Core/Coercion/Opt.hs
@@ -296,7 +296,8 @@ opt_co4 env sym rep r (CoVarCo cv)
     cv1 = case lookupInScope (lcInScopeSet env) cv of
              Just cv1 -> cv1
              Nothing  -> warnPprTrace True
-                          (text "opt_co: not in scope:" <+> ppr cv $$ ppr env)
+                          "opt_co: not in scope"
+                          (ppr cv $$ ppr env)
                           cv
           -- cv1 might have a substituted kind!
 
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs
index 9d2e873b56..9ff08b142b 100644
--- a/compiler/GHC/Core/Opt/Arity.hs
+++ b/compiler/GHC/Core/Opt/Arity.hs
@@ -655,8 +655,8 @@ findRhsArity dflags bndr rhs old_arity
       | otherwise               =
          -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]
          warnPprTrace (debugIsOn && n > 2)
-            (text "Exciting arity" $$ nest 2
-              ( ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $
+            "Exciting arity"
+            (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $
             go (n+1) next_at
       where
         next_at = step cur_at
@@ -1622,7 +1622,7 @@ mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty
        | otherwise       -- We have an expression of arity > 0,
                          -- but its type isn't a function, or a binder
                          -- does not have a fixed runtime representation
-       = warnPprTrace True ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr)
+       = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr)
          (getTCvInScope subst, EI [] MRefl)
         -- This *can* legitimately happen:
         -- e.g.  coerce Int (\x. x) Essentially the programmer is
@@ -1938,7 +1938,7 @@ etaExpandToJoinPoint join_arity expr
 
 etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule
 etaExpandToJoinPointRule _ rule@(BuiltinRule {})
-  = warnPprTrace True (sep [text "Can't eta-expand built-in rule:", ppr rule])
+  = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule)
       -- How did a local binding get a built-in rule anyway? Probably a plugin.
     rule
 etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs
diff --git a/compiler/GHC/Core/Opt/ConstantFold.hs b/compiler/GHC/Core/Opt/ConstantFold.hs
index 919520cb83..9521d4d4a6 100644
--- a/compiler/GHC/Core/Opt/ConstantFold.hs
+++ b/compiler/GHC/Core/Opt/ConstantFold.hs
@@ -1814,7 +1814,7 @@ tagToEnumRule = do
       return $ mkTyApps (Var (dataConWorkId dc)) tc_args
 
     -- See Note [tagToEnum#]
-    _ -> warnPprTrace True (text "tagToEnum# on non-enumeration type" <+> ppr ty) $
+    _ -> warnPprTrace True "tagToEnum# on non-enumeration type" (ppr ty) $
          return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"
 
 ------------------------------
diff --git a/compiler/GHC/Core/Opt/OccurAnal.hs b/compiler/GHC/Core/Opt/OccurAnal.hs
index 7df9ead69f..12269b0a29 100644
--- a/compiler/GHC/Core/Opt/OccurAnal.hs
+++ b/compiler/GHC/Core/Opt/OccurAnal.hs
@@ -82,8 +82,7 @@ occurAnalysePgm this_mod active_unf active_rule imp_rules binds
   = occ_anald_binds
 
   | otherwise   -- See Note [Glomming]
-  = warnPprTrace True (hang (text "Glomming in" <+> ppr this_mod <> colon)
-                        2 (ppr final_usage))
+  = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))
     occ_anald_glommed_binds
   where
     init_env = initOccEnv { occ_rule_act = active_rule
@@ -3131,7 +3130,7 @@ decideJoinPointHood TopLevel _ _
 decideJoinPointHood NotTopLevel usage bndrs
   | isJoinId (head bndrs)
   = warnPprTrace (not all_ok)
-                 (text "OccurAnal failed to rediscover join point(s):" <+> ppr bndrs)
+                 "OccurAnal failed to rediscover join point(s)" (ppr bndrs)
                  all_ok
   | otherwise
   = all_ok
diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 41bae56242..8b1106904f 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -690,7 +690,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
         -- about to begin, with '1' for the first
       | iteration_no > max_iterations   -- Stop if we've run out of iterations
       = warnPprTrace (debugIsOn && (max_iterations > 2))
-            ( hang (ppr this_mod <> colon <+> text "simplifier bailing out after"
+            "Simplifier bailing out"
+            ( hang (ppr this_mod <> text ", after"
                     <+> int max_iterations <+> text "iterations"
                     <+> (brackets $ hsep $ punctuate comma $
                          map (int . simplCountN) (reverse counts_so_far)))
@@ -995,7 +996,7 @@ shortMeOut ind_env exported_id local_id
     then
         if hasShortableIdInfo exported_id
         then True       -- See Note [Messing up the exported Id's IdInfo]
-        else warnPprTrace True (text "Not shorting out:" <+> ppr exported_id) False
+        else warnPprTrace True "Not shorting out" (ppr exported_id) False
     else
         False
 
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index c5ad4e4b1c..eab4d0ef4e 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -1703,7 +1703,7 @@ abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs
         -- and add the tyvars of the Id (if necessary)
     zap v | isId v = warnPprTrace (isStableUnfolding (idUnfolding v) ||
                            not (isEmptyRuleInfo (idSpecialisation v)))
-                           (text "absVarsOf: discarding info on" <+> ppr v) $
+                           "absVarsOf: discarding info on" (ppr v) $
                      setIdInfo v vanillaIdInfo
           | otherwise = v
 
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 0e945043b6..b21d931c25 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -3170,6 +3170,7 @@ addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv
 addBinderUnfolding env bndr unf
   | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf
   = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))
+          "unfolding type mismatch"
           (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $
           modifyInScope env (bndr `setIdUnfolding` unf)
 
@@ -3336,7 +3337,7 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
                 -- it "sees" that the entire branch of an outer case is
                 -- inaccessible.  So we simply put an error case here instead.
 missingAlt env case_bndr _ cont
-  = warnPprTrace True (text "missingAlt" <+> ppr case_bndr) $
+  = warnPprTrace True "missingAlt" (ppr case_bndr) $
     -- See Note [Avoiding space leaks in OutType]
     let cont_ty = contResultType cont
     in seqType cont_ty `seq`
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 5c3114e76b..d0b8445665 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -568,7 +568,7 @@ mkArgInfo env fun rules n_val_args call_cont
                    else
                         demands ++ vanilla_dmds
                | otherwise
-               -> warnPprTrace True (text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
+               -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun)
                                 <+> ppr n_val_args <+> ppr demands) $
                   vanilla_dmds      -- Not enough args, or no strictness
 
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 03cce88623..9c4c52107a 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -2226,8 +2226,8 @@ callToPats env bndr_occs call@(Call fn args con_env)
 
         ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $
           warnPprTrace (not (isEmptyVarSet bad_covars))
-              ( text "SpecConstr: bad covars:" <+> ppr bad_covars
-                $$ ppr call) $
+              "SpecConstr: bad covars"
+              (ppr bad_covars $$ ppr call) $
           if interesting && isEmptyVarSet bad_covars
           then
               -- pprTraceM "callToPatsOut" (
@@ -2530,7 +2530,7 @@ samePat (CP { cp_qvars = vs1, cp_args = as1 })
     same e1 (Tick _ e2) = same e1 e2
     same e1 (Cast e2 _) = same e1 e2
 
-    same e1 e2 = warnPprTrace (bad e1 || bad e2) (ppr e1 $$ ppr e2) $
+    same e1 e2 = warnPprTrace (bad e1 || bad e2) "samePat" (ppr e1 $$ ppr e2) $
                  False  -- Let, lambda, case should not occur
     bad (Case {}) = True
     bad (Let {})  = True
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index f158041fc8..f5070e77b8 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1442,7 +1442,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
 
   | otherwise   -- No calls or RHS doesn't fit our preconceptions
   = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)
-          (text "Missed specialisation opportunity for" <+> ppr fn $$ _trace_doc) $
+          "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $
           -- Note [Specialisation shape]
     -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
     return ([], [], emptyUDs)
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index 96e68d62d6..5b31f76ed1 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -723,6 +723,7 @@ by LitRubbish (see Note [Drop absent bindings]) so there is no great harm.
 splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)]
 splitFun ww_opts fn_id rhs
   = warnPprTrace (not (wrap_dmds `lengthIs` (arityInfo fn_info)))
+                 "splitFun"
                  (ppr fn_id <+> (ppr wrap_dmds $$ ppr cpr)) $
     do { mb_stuff <- mkWwBodies ww_opts fn_id arg_vars (exprType body) wrap_dmds cpr
        ; case mb_stuff of
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index ce02f46e45..698a85988a 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -280,8 +280,8 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
     too_many_args_for_join_point wrap_args
       | Just join_arity <- mb_join_arity
       , wrap_args `lengthExceeds` join_arity
-      = warnPprTrace True (text "Unable to worker/wrapper join point with arity " <+>
-                     int join_arity <+> text "but" <+>
+      = warnPprTrace True "Unable to worker/wrapper join point"
+                     (text "arity" <+> int join_arity <+> text "but" <+>
                      int (length wrap_args) <+> text "args") $
         True
       | otherwise
@@ -610,7 +610,7 @@ wantToUnboxResult fam_envs ty cpr
 
   where
     -- | See Note [non-algebraic or open body type warning]
-    open_body_ty_warning = warnPprTrace True (text "wantToUnboxResult: non-algebraic or open body type" <+> ppr ty) Nothing
+    open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing
 
 isLinear :: Scaled a -> Bool
 isLinear (Scaled w _ ) =
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 2df35f01ea..381cd4f561 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -293,8 +293,9 @@ mkCast (Coercion e_co) co
 
 mkCast (Cast expr co2) co
   = warnPprTrace (let { from_ty = coercionLKind co;
-               to_ty2  = coercionRKind co2 } in
-            not (from_ty `eqType` to_ty2))
+                        to_ty2  = coercionRKind co2 } in
+                     not (from_ty `eqType` to_ty2))
+             "mkCast"
              (vcat ([ text "expr:" <+> ppr expr
                    , text "co2:" <+> ppr co2
                    , text "co:" <+> ppr co ])) $
@@ -306,7 +307,7 @@ mkCast (Tick t expr) co
 mkCast expr co
   = let from_ty = coercionLKind co in
     warnPprTrace (not (from_ty `eqType` exprType expr))
-          (text "Trying to coerce" <+> text "(" <> ppr expr
+          "Trying to coerce" (text "(" <> ppr expr
           $$ text "::" <+> ppr (exprType expr) <> text ")"
           $$ ppr co $$ ppr (coercionType co)
           $$ callStackDoc) $
diff --git a/compiler/GHC/CoreToIface.hs b/compiler/GHC/CoreToIface.hs
index 4ce87ae50b..426dcae9cf 100644
--- a/compiler/GHC/CoreToIface.hs
+++ b/compiler/GHC/CoreToIface.hs
@@ -372,7 +372,7 @@ toIfaceAppArgsX fr kind ty_args
         -- This is probably a compiler bug, so we print a trace and
         -- carry on as if it were FunTy.  Without the test for
         -- isEmptyTCvSubst we'd get an infinite loop (#15473)
-        warnPprTrace True (ppr kind $$ ppr ty_args) $
+        warnPprTrace True "toIfaceAppArgsX" (ppr kind $$ ppr ty_args) $
         IA_Arg (toIfaceTypeX fr t1) Required (go env ty ts1)
 
 tidyToIfaceType :: TidyEnv -> Type -> IfaceType
diff --git a/compiler/GHC/CoreToStg.hs b/compiler/GHC/CoreToStg.hs
index 8d99965513..8540421639 100644
--- a/compiler/GHC/CoreToStg.hs
+++ b/compiler/GHC/CoreToStg.hs
@@ -620,7 +620,7 @@ coreToStgArgs (arg : args) = do         -- Non-type argument
         stg_arg_rep = typePrimRep (stgArgType stg_arg)
         bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep)
 
-    warnPprTrace bad_args (text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg) $
+    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $
      return (stg_arg : stg_args, ticks ++ aticks)
 
 coreToStgTick :: Type -- type of the ticked expression
diff --git a/compiler/GHC/CoreToStg/Prep.hs b/compiler/GHC/CoreToStg/Prep.hs
index e3932e835e..f1e0fa2e3f 100644
--- a/compiler/GHC/CoreToStg/Prep.hs
+++ b/compiler/GHC/CoreToStg/Prep.hs
@@ -657,7 +657,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
        ; (floats3, rhs3)
             <- if manifestArity rhs1 <= arity
                then return (floats2, cpeEtaExpand arity rhs2)
-               else warnPprTrace True (text "CorePrep: silly extra arguments:" <+> ppr bndr) $
+               else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $
                                -- Note [Silly extra arguments]
                     (do { v <- newVar (idType bndr)
                         ; let float = mkFloat topDmd False v rhs2
diff --git a/compiler/GHC/Data/List/SetOps.hs b/compiler/GHC/Data/List/SetOps.hs
index 9a5d138863..187d862b3d 100644
--- a/compiler/GHC/Data/List/SetOps.hs
+++ b/compiler/GHC/Data/List/SetOps.hs
@@ -66,7 +66,7 @@ unionLists xs [y]
   | isIn "unionLists" y xs = xs
   | otherwise = y:xs
 unionLists xs ys
-  = warnPprTrace (lengthExceeds xs 100 || lengthExceeds ys 100) (ppr xs $$ ppr ys) $
+  = warnPprTrace (lengthExceeds xs 100 || lengthExceeds ys 100) "unionLists" (ppr xs $$ ppr ys) $
     [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
 
 -- | Calculate the set difference of two lists. This is
@@ -207,7 +207,7 @@ isIn msg x ys
     elem100 :: Eq a => Int -> a -> [a] -> Bool
     elem100 _ _ [] = False
     elem100 i x (y:ys)
-      | i > 100 = warnPprTrace True (text ("Over-long elem in " ++ msg)) (x `elem` (y:ys))
+      | i > 100 = warnPprTrace True ("Over-long elem in " ++ msg) empty (x `elem` (y:ys))
       | otherwise = x == y || elem100 (i + 1) x ys
 
 isn'tIn msg x ys
@@ -216,6 +216,6 @@ isn'tIn msg x ys
     notElem100 :: Eq a => Int -> a -> [a] -> Bool
     notElem100 _ _ [] =  True
     notElem100 i x (y:ys)
-      | i > 100 = warnPprTrace True (text ("Over-long notElem in " ++ msg)) (x `notElem` (y:ys))
+      | i > 100 = warnPprTrace True ("Over-long notElem in " ++ msg) empty (x `notElem` (y:ys))
       | otherwise = x /= y && notElem100 (i + 1) x ys
 # endif /* DEBUG */
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index d30d39372c..0055cea807 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -540,7 +540,7 @@ loadInterface doc_str mod from
                             -- of one's own boot file! (one-shot only)
                             -- See Note [Loading your own hi-boot file]
 
-        ; warnPprTrace bad_boot (ppr mod) $
+        ; warnPprTrace bad_boot "loadInterface" (ppr mod) $
           updateEps_  $ \ eps ->
            if elemModuleEnv mod (eps_PIT eps) || is_external_sig mhome_unit iface
                 then eps
diff --git a/compiler/GHC/Iface/Make.hs b/compiler/GHC/Iface/Make.hs
index 9627752811..2893e3857c 100644
--- a/compiler/GHC/Iface/Make.hs
+++ b/compiler/GHC/Iface/Make.hs
@@ -162,7 +162,7 @@ updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf
     update_decl (IfaceId nm ty details infos)
       | let not_caffy = elemNameSet nm non_cafs
       , let mb_lf_info = lookupNameEnv lf_infos nm
-      , warnPprTrace (isNothing mb_lf_info) (text "Name without LFInfo:" <+> ppr nm) True
+      , warnPprTrace (isNothing mb_lf_info) "Name without LFInfo" (ppr nm) True
         -- Only allocate a new IfaceId if we're going to update the infos
       , isJust mb_lf_info || not_caffy
       = IfaceId nm ty details $
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index ed5e99805f..f21dd7f9f4 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -763,7 +763,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
                 -- unfolding in the *definition*; so look up in binder_set
           refined_id = case lookupVarSet binder_set idocc of
                          Just id -> id
-                         Nothing -> warnPprTrace True (ppr idocc) idocc
+                         Nothing -> warnPprTrace True "chooseExternalIds" (ppr idocc) idocc
 
           unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
           referrer' | isExportedId refined_id = refined_id
@@ -1290,7 +1290,7 @@ tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
 
     sig = dmdSigInfo idinfo
     final_sig | not $ isTopSig sig
-              = warnPprTrace (_bottom_hidden sig) (ppr name) sig
+              = warnPprTrace (_bottom_hidden sig) "tidyTopIdInfo" (ppr name) sig
               -- try a cheap-and-cheerful bottom analyser
               | Just (_, nsig) <- mb_bot_str = nsig
               | otherwise                    = sig
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 8108a9e873..c0d704728a 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -371,7 +371,7 @@ rnImportDecl this_mod
 
     -- Compiler sanity check: if the import didn't say
     -- {-# SOURCE #-} we should not get a hi-boot file
-    warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) (ppr imp_mod_name) $ do
+    warnPprTrace ((want_boot == NotBoot) && (mi_boot iface == IsBoot)) "rnImportDecl" (ppr imp_mod_name) $ do
 
     -- Issue a user warning for a redundant {- SOURCE -} import
     -- NB that we arrange to read all the ordinary imports before
diff --git a/compiler/GHC/Runtime/Eval.hs b/compiler/GHC/Runtime/Eval.hs
index 3d4e92d438..c514cd105b 100644
--- a/compiler/GHC/Runtime/Eval.hs
+++ b/compiler/GHC/Runtime/Eval.hs
@@ -669,8 +669,8 @@ rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do
              Just new_ty -> do
               case improveRTTIType hsc_env old_ty new_ty of
                Nothing -> return $
-                        warnPprTrace True (text (":print failed to calculate the "
-                                           ++ "improvement for a type")) hsc_env
+                        warnPprTrace True (":print failed to calculate the "
+                                           ++ "improvement for a type") empty hsc_env
                Just subst -> do
                  let logger = hsc_logger hsc_env
                  putDumpFileMaybe logger Opt_D_dump_rtti "RTTI"
diff --git a/compiler/GHC/Stg/Subst.hs b/compiler/GHC/Stg/Subst.hs
index 487b8b8adc..fa7107fc86 100644
--- a/compiler/GHC/Stg/Subst.hs
+++ b/compiler/GHC/Stg/Subst.hs
@@ -54,7 +54,7 @@ lookupIdSubst id (Subst in_scope env)
   | not (isLocalId id) = id
   | Just id' <- lookupVarEnv env id = id'
   | Just id' <- lookupInScope in_scope id = id'
-  | otherwise = warnPprTrace True (text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope) id
+  | otherwise = warnPprTrace True "StgSubst.lookupIdSubst" (ppr id $$ ppr in_scope) id
 
 -- | Substitutes an occurrence of an identifier for its counterpart recorded
 -- in the 'Subst'. Does not generate a debug warning if the identifier to
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index bec5af03b0..34ae24d68c 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -590,7 +590,7 @@ mkPragEnv sigs binds
         -- add arity only for real INLINE pragmas, not INLINABLE
       = case lookupNameEnv ar_env n of
           Just ar -> inl_prag { inl_sat = Just ar }
-          Nothing -> warnPprTrace True (text "mkPragEnv no arity" <+> ppr n) $
+          Nothing -> warnPprTrace True "mkPragEnv no arity" (ppr n) $
                      -- There really should be a binding for every INLINE pragma
                      inl_prag
       | otherwise
diff --git a/compiler/GHC/Tc/Types/Origin.hs b/compiler/GHC/Tc/Types/Origin.hs
index a2229342d8..d7c68ccd17 100644
--- a/compiler/GHC/Tc/Types/Origin.hs
+++ b/compiler/GHC/Tc/Types/Origin.hs
@@ -288,7 +288,7 @@ pprSkolInfo RuntimeUnkSkol     = text "Unknown type from GHCi runtime"
 -- UnkSkol
 -- For type variables the others are dealt with by pprSkolTvBinding.
 -- For Insts, these cases should not happen
-pprSkolInfo UnkSkol = warnPprTrace True (text "pprSkolInfo: UnkSkol") $ text "UnkSkol"
+pprSkolInfo UnkSkol = warnPprTrace True "pprSkolInfo: UnkSkol" empty $ text "UnkSkol"
 
 pprSigSkolInfo :: UserTypeCtxt -> TcType -> SDoc
 -- The type is already tidied
diff --git a/compiler/GHC/Tc/Utils/TcMType.hs b/compiler/GHC/Tc/Utils/TcMType.hs
index 699bf5f69a..438445eb66 100644
--- a/compiler/GHC/Tc/Utils/TcMType.hs
+++ b/compiler/GHC/Tc/Utils/TcMType.hs
@@ -1931,7 +1931,7 @@ skolemiseUnboundMetaTyVar tv
         do { cts <- readMetaTyVar tv
            ; case cts of
                Flexi       -> return ()
-               Indirect ty -> warnPprTrace True (ppr tv $$ ppr ty) $
+               Indirect ty -> warnPprTrace True "skolemiseUnboundMetaTyVar" (ppr tv $$ ppr ty) $
                               return () }
 
 {- Note [Error on unconstrained meta-variables]
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index df34dd12fd..1245b372af 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -605,8 +605,9 @@ idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)
 
 asJoinId :: Id -> JoinArity -> JoinId
 asJoinId id arity = warnPprTrace (not (isLocalId id))
-                         (text "global id being marked as join var:" <+> ppr id) $
+                         "global id being marked as join var"  (ppr id) $
                     warnPprTrace (not (is_vanilla_or_join id))
+                         "asJoinId"
                          (ppr id <+> pprIdDetails (idDetails id)) $
                     id `setIdDetails` JoinId arity
   where
diff --git a/compiler/GHC/Types/TyThing/Ppr.hs b/compiler/GHC/Types/TyThing/Ppr.hs
index efe1a748b5..536fb63b43 100644
--- a/compiler/GHC/Types/TyThing/Ppr.hs
+++ b/compiler/GHC/Types/TyThing/Ppr.hs
@@ -184,7 +184,7 @@ pprTyThing ss ty_thing
          = case nameModule_maybe name of
              Just mod -> Just $ \occ -> getPprStyle $ \sty ->
                pprModulePrefix sty mod occ <> ppr occ
-             Nothing  -> warnPprTrace True (ppr name) Nothing
+             Nothing  -> warnPprTrace True "pprTyThing" (ppr name) Nothing
              -- Nothing is unexpected here; TyThings have External names
 
 showWithLoc :: SDoc -> SDoc -> SDoc
diff --git a/compiler/GHC/Utils/Trace.hs b/compiler/GHC/Utils/Trace.hs
index 5da6e6e5d9..c8b0bba3e5 100644
--- a/compiler/GHC/Utils/Trace.hs
+++ b/compiler/GHC/Utils/Trace.hs
@@ -63,13 +63,13 @@ pprSTrace :: HasCallStack => SDoc -> a -> a
 pprSTrace doc = pprTrace "" (doc $$ traceCallStackDoc)
 
 -- | Just warn about an assertion failure, recording the given file and line number.
-warnPprTrace :: HasCallStack => Bool -> SDoc -> a -> a
-warnPprTrace _     _    x | not debugIsOn     = x
-warnPprTrace _     _msg x | unsafeHasNoDebugOutput = x
-warnPprTrace False _msg x = x
-warnPprTrace True   msg x
+warnPprTrace :: HasCallStack => Bool -> String -> SDoc -> a -> a
+warnPprTrace _     _s _    x | not debugIsOn     = x
+warnPprTrace _     _s _msg x | unsafeHasNoDebugOutput = x
+warnPprTrace False _s _msg x = x
+warnPprTrace True   s  msg x
   = pprDebugAndThen defaultSDocContext trace (text "WARNING:")
-                    (msg $$ withFrozenCallStack traceCallStackDoc )
+                    (text s $$ msg $$ withFrozenCallStack traceCallStackDoc )
                     x
 
 -- | For when we want to show the user a non-fatal WARNING so that they can