Fix #18052 by using pprPrefixOcc in more places

This fixes several small oversights in the choice of pretty-printing
function to use. Fixes #18052.

9 files changed, 96 insertions, 34 deletions

diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs
index df12815e6c..df88351df2 100644
--- a/compiler/GHC/Core/Ppr.hs
+++ b/compiler/GHC/Core/Ppr.hs
@@ -123,11 +123,13 @@ ppr_binding ann (val_bdr, expr)
          , pp_bind
          ]
   where
+    pp_val_bdr = pprPrefixOcc val_bdr
+
     pp_bind = case bndrIsJoin_maybe val_bdr of
                 Nothing -> pp_normal_bind
                 Just ar -> pp_join_bind ar
 
-    pp_normal_bind = hang (ppr val_bdr) 2 (equals <+> pprCoreExpr expr)
+    pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr)
 
       -- For a join point of join arity n, we want to print j = \x1 ... xn -> e
       -- as "j x1 ... xn = e" to differentiate when a join point returns a
@@ -135,7 +137,7 @@ ppr_binding ann (val_bdr, expr)
       -- an n-argument function).
     pp_join_bind join_arity
       | bndrs `lengthAtLeast` join_arity
-      = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
+      = hang (pp_val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
            2 (equals <+> pprCoreExpr rhs)
       | otherwise -- Yikes!  A join-binding with too few lambda
                   -- Lint will complain, but we don't want to crash
@@ -164,8 +166,10 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
         -- an atomic value (e.g. function args)
 
 ppr_expr add_par (Var name)
- | isJoinId name               = add_par ((text "jump") <+> ppr name)
- | otherwise                   = ppr name
+ | isJoinId name               = add_par ((text "jump") <+> pp_name)
+ | otherwise                   = pp_name
+ where
+   pp_name = pprPrefixOcc name
 ppr_expr add_par (Type ty)     = add_par (text "TYPE:" <+> ppr ty)       -- Weird
 ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co)
 ppr_expr add_par (Lit lit)     = pprLiteral add_par lit
@@ -429,7 +433,7 @@ pprKindedTyVarBndr tyvar
 -- pprIdBndr does *not* print the type
 -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness
 pprIdBndr :: Id -> SDoc
-pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
+pprIdBndr id = pprPrefixOcc id <+> pprIdBndrInfo (idInfo id)
 
 pprIdBndrInfo :: IdInfo -> SDoc
 pprIdBndrInfo info
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs
index a27aab1730..4e5f2be37d 100644
--- a/compiler/GHC/Tc/Module.hs
+++ b/compiler/GHC/Tc/Module.hs
@@ -2122,7 +2122,7 @@ tcRnStmt hsc_env rdr_stmt
     }
   where
     bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:",
-                                  nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
+                                  nest 2 (pprPrefixOcc id <+> dcolon <+> ppr (idType id))])
 
 {-
 --------------------------------------------------------------------------
@@ -2903,7 +2903,7 @@ ppr_types debug type_env
              -- etc are suppressed (unless -dppr-debug),
              -- because they appear elsewhere
 
-    ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
+    ppr_sig id = hang (pprPrefixOcc id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
 
 ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc
 ppr_tycons debug fam_insts type_env
@@ -2921,7 +2921,7 @@ ppr_tycons debug fam_insts type_env
                      | otherwise  = isExternalName (tyConName tycon) &&
                                     not (tycon `elem` fi_tycons)
     ppr_tc tc
-       = vcat [ hang (ppr (tyConFlavour tc) <+> ppr tc
+       = vcat [ hang (ppr (tyConFlavour tc) <+> pprPrefixOcc (tyConName tc)
                       <> braces (ppr (tyConArity tc)) <+> dcolon)
                    2 (ppr (tidyTopType (tyConKind tc)))
               , nest 2 $
@@ -2955,7 +2955,7 @@ ppr_patsyns type_env
   = ppr_things "PATTERN SYNONYMS" ppr_ps
                (typeEnvPatSyns type_env)
   where
-    ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps
+    ppr_ps ps = pprPrefixOcc ps <+> dcolon <+> pprPatSynType ps
 
 ppr_insts :: [ClsInst] -> SDoc
 ppr_insts ispecs
diff --git a/testsuite/tests/ghci/should_fail/T18052b.script b/testsuite/tests/ghci/should_fail/T18052b.script
new file mode 100644
index 0000000000..07bcdcec19
--- /dev/null
+++ b/testsuite/tests/ghci/should_fail/T18052b.script
@@ -0,0 +1,2 @@
+:set -XMagicHash
+let (%%%) = 1#
diff --git a/testsuite/tests/ghci/should_fail/T18052b.stderr b/testsuite/tests/ghci/should_fail/T18052b.stderr
new file mode 100644
index 0000000000..30d2a389ab
--- /dev/null
+++ b/testsuite/tests/ghci/should_fail/T18052b.stderr
@@ -0,0 +1,3 @@
+
+<interactive>:1:1: error:
+    GHCi can't bind a variable of unlifted type: (%%%) :: GHC.Prim.Int#
diff --git a/testsuite/tests/ghci/should_fail/all.T b/testsuite/tests/ghci/should_fail/all.T
index 7205cfd930..6c8d0ac000 100644
--- a/testsuite/tests/ghci/should_fail/all.T
+++ b/testsuite/tests/ghci/should_fail/all.T
@@ -3,3 +3,4 @@ test('T10549a', [], ghci_script, ['T10549a.script'])
 test('T15055', normalise_version('ghc'), ghci_script, ['T15055.script'])
 test('T16013', [], ghci_script, ['T16013.script'])
 test('T16287', [], ghci_script, ['T16287.script'])
+test('T18052b', [], ghci_script, ['T18052b.script'])
diff --git a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
index 3b94743dbb..09a6ce2a17 100644
--- a/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
+++ b/testsuite/tests/partial-sigs/should_compile/ExtraConstraints3.stderr
@@ -1,28 +1,28 @@
 TYPE SIGNATURES
-  !! :: forall {a}. [a] -> Int -> a
-  $ :: forall {a} {b}. (a -> b) -> a -> b
-  $! :: forall {a} {b}. (a -> b) -> a -> b
-  && :: Bool -> Bool -> Bool
-  * :: forall {a}. Num a => a -> a -> a
-  ** :: forall {a}. Floating a => a -> a -> a
-  + :: forall {a}. Num a => a -> a -> a
-  ++ :: forall {a}. [a] -> [a] -> [a]
-  - :: forall {a}. Num a => a -> a -> a
-  . :: forall {b} {c} {a}. (b -> c) -> (a -> b) -> a -> c
-  / :: forall {a}. Fractional a => a -> a -> a
-  /= :: forall {a}. Eq a => a -> a -> Bool
-  < :: forall {a}. Ord a => a -> a -> Bool
-  <= :: forall {a}. Ord a => a -> a -> Bool
-  =<< ::
+  (!!) :: forall {a}. [a] -> Int -> a
+  ($) :: forall {a} {b}. (a -> b) -> a -> b
+  ($!) :: forall {a} {b}. (a -> b) -> a -> b
+  (&&) :: Bool -> Bool -> Bool
+  (*) :: forall {a}. Num a => a -> a -> a
+  (**) :: forall {a}. Floating a => a -> a -> a
+  (+) :: forall {a}. Num a => a -> a -> a
+  (++) :: forall {a}. [a] -> [a] -> [a]
+  (-) :: forall {a}. Num a => a -> a -> a
+  (.) :: forall {b} {c} {a}. (b -> c) -> (a -> b) -> a -> c
+  (/) :: forall {a}. Fractional a => a -> a -> a
+  (/=) :: forall {a}. Eq a => a -> a -> Bool
+  (<) :: forall {a}. Ord a => a -> a -> Bool
+  (<=) :: forall {a}. Ord a => a -> a -> Bool
+  (=<<) ::
     forall {m :: * -> *} {a} {b}. Monad m => (a -> m b) -> m a -> m b
-  == :: forall {a}. Eq a => a -> a -> Bool
-  > :: forall {a}. Ord a => a -> a -> Bool
-  >= :: forall {a}. Ord a => a -> a -> Bool
-  >> :: forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
-  >>= ::
+  (==) :: forall {a}. Eq a => a -> a -> Bool
+  (>) :: forall {a}. Ord a => a -> a -> Bool
+  (>=) :: forall {a}. Ord a => a -> a -> Bool
+  (>>) :: forall {m :: * -> *} {a} {b}. Monad m => m a -> m b -> m b
+  (>>=) ::
     forall {m :: * -> *} {a} {b}. Monad m => m a -> (a -> m b) -> m b
-  ^ :: forall {b} {a}. (Integral b, Num a) => a -> b -> a
-  ^^ :: forall {a} {b}. (Fractional a, Integral b) => a -> b -> a
+  (^) :: forall {b} {a}. (Integral b, Num a) => a -> b -> a
+  (^^) :: forall {a} {b}. (Fractional a, Integral b) => a -> b -> a
   abs :: forall {a}. Num a => a -> a
   acos :: forall {a}. Floating a => a -> a
   acosh :: forall {a}. Floating a => a -> a
@@ -234,7 +234,7 @@ TYPE SIGNATURES
   zipWith3 ::
     forall {a} {b} {c} {d}.
     (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
-  || :: Bool -> Bool -> Bool
+  (||) :: Bool -> Bool -> Bool
 Dependent modules: []
-Dependent packages: [base-4.13.0.0, ghc-prim-0.6.1,
-                     integer-gmp-1.0.2.0]
+Dependent packages: [base-4.14.0.0, ghc-prim-0.6.1,
+                     integer-gmp-1.0.3.0]
diff --git a/testsuite/tests/printer/T18052a.hs b/testsuite/tests/printer/T18052a.hs
new file mode 100644
index 0000000000..6cf5a374be
--- /dev/null
+++ b/testsuite/tests/printer/T18052a.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeOperators #-}
+module T18052a where
+
+(+++) = (++)
+pattern x :||: y = (x,y)
+type (^^^) = Either
+data (&&&)
diff --git a/testsuite/tests/printer/T18052a.stderr b/testsuite/tests/printer/T18052a.stderr
new file mode 100644
index 0000000000..1ac260a73b
--- /dev/null
+++ b/testsuite/tests/printer/T18052a.stderr
@@ -0,0 +1,42 @@
+TYPE SIGNATURES
+  (+++) :: forall {a}. [a] -> [a] -> [a]
+TYPE CONSTRUCTORS
+  data type (&&&){0} :: *
+  type synonym (^^^){0} :: * -> * -> *
+PATTERN SYNONYMS
+  (:||:) :: forall {a} {b}. a -> b -> (a, b)
+Dependent modules: []
+Dependent packages: [base-4.14.0.0, ghc-prim-0.6.1,
+                     integer-gmp-1.0.3.0]
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 18, types: 53, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+T18052a.$b:||: :: forall {a} {b}. a -> b -> (a, b)
+[GblId, Arity=2, Unf=OtherCon []]
+T18052a.$b:||: = GHC.Tuple.(,)
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+(+++) :: forall {a}. [a] -> [a] -> [a]
+[GblId]
+(+++) = (++)
+
+-- RHS size: {terms: 13, types: 20, coercions: 0, joins: 0/0}
+T18052a.$m:||:
+  :: forall {rep :: GHC.Types.RuntimeRep} {r :: TYPE rep} {a} {b}.
+     (a, b) -> (a -> b -> r) -> (GHC.Prim.Void# -> r) -> r
+[GblId, Arity=3, Unf=OtherCon []]
+T18052a.$m:||:
+  = \ (@(rep :: GHC.Types.RuntimeRep))
+      (@(r :: TYPE rep))
+      (@a)
+      (@b)
+      (scrut :: (a, b))
+      (cont :: a -> b -> r)
+      _ [Occ=Dead] ->
+      case scrut of { (x, y) -> cont x y }
+
+
+
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index d476927406..597f83aa9c 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -57,3 +57,5 @@ test('T14306', ignore_stderr, makefile_test, ['T14306'])
 test('T14343', normal, compile_fail, [''])
 test('T14343b', normal, compile_fail, [''])
 test('T15761', normal, compile_fail, [''])
+test('T18052a', normal, compile,
+     ['-ddump-simpl -ddump-types -dno-typeable-binds -dsuppress-uniques'])