Simplify OutputableBndr

This replaces three methods in OutputableBndr with one,
and adds comments.

There's also a tiny change in the placement of equals signs in
debug-prints.  I like it better that way, but if it complicates
life for anyone we can put it back.

8 files changed, 76 insertions, 78 deletions

diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs
index 970f4cc411..45275e3eff 100644
--- a/compiler/basicTypes/Name.hs
+++ b/compiler/basicTypes/Name.hs
@@ -524,7 +524,6 @@ instance OutputableBndr Name where
     pprInfixOcc  = pprInfixName
     pprPrefixOcc = pprPrefixName
 
-
 pprName :: Name -> SDoc
 pprName (Name {n_sort = sort, n_uniq = u, n_occ = occ})
   = getPprStyle $ \ sty ->
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 2930a24545..9d42f7a28c 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -1724,9 +1724,7 @@ instance (OutputableBndr Var, Outputable b) =>
   pprBndr _ b = ppr b   -- Simple
   pprInfixOcc  b = ppr b
   pprPrefixOcc b = ppr b
-  pprNonRecBndrKeyword (TB b _) = pprNonRecBndrKeyword b
-  pprRecBndrKeyword    (TB b _) = pprRecBndrKeyword    b
-  pprLamsOnLhs         (TB b _) = pprLamsOnLhs         b
+  bndrIsJoin_maybe (TB b _) = isJoinId_maybe b
 
 deTagExpr :: TaggedExpr t -> CoreExpr
 deTagExpr (Var v)                   = Var v
diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index c61b16605e..a8dc2179a1 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -113,15 +113,23 @@ ppr_bind ann (Rec binds)           = vcat (map pp binds)
 
 ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
 ppr_binding ann (val_bdr, expr)
-  = ann expr $$ pprBndr LetBind val_bdr $$
-    hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs) <+> equals) 2
-         (pprCoreExpr rhs)
+  = ann expr $$ pprBndr LetBind val_bdr $$ pp_bind
   where
-    (bndrs, body)          = collectBinders expr
-    (lhs_bndrs, rhs_bndrs) = splitAt (pprLamsOnLhs val_bdr) bndrs
-    rhs                    = mkLams rhs_bndrs body
-                      -- Returns ([], expr) unless it's a join point, in which
-                      -- case we want the args before the =
+    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)
+
+      -- 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
+      -- lambda (the first rendering looks like a nullary join point returning
+      -- an n-argument function).
+    pp_join_bind join_arity
+      = hang (ppr val_bdr <+> sep (map (pprBndr LambdaBind) lhs_bndrs))
+           2 (equals <+> pprCoreExpr rhs)
+      where
+        (lhs_bndrs, rhs) = collectNBinders join_arity expr
 
 pprParendExpr expr = ppr_expr parens expr
 pprCoreExpr   expr = ppr_expr noParens expr
@@ -249,17 +257,20 @@ ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _))
      pprCoreExpr expr)
 -}
 
+
 -- General case (recursive case, too)
 ppr_expr add_par (Let bind expr)
   = add_par $
-    sep [hang (keyword <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"),
+    sep [hang (keyword bind <+> char '{') 2 (ppr_bind noAnn bind <+> text "} in"),
          pprCoreExpr expr]
   where
-    keyword = case bind of
-                NonRec b _    -> pprNonRecBndrKeyword b
-                Rec ((b,_):_) -> pprRecBndrKeyword    b
-                Rec []        -> text "let" -- This *shouldn't* happen, but
-                                            -- let's be tolerant here
+    keyword (NonRec b _)
+     | isJust (bndrIsJoin_maybe b) = text "join"
+     | otherwise                   = text "let"
+    keyword (Rec pairs)
+     | ((b,_):_) <- pairs
+     , isJust (bndrIsJoin_maybe b) = text "joinrec"
+     | otherwise                   = text "letrec"
 
 ppr_expr add_par (Tick tickish expr)
   = sdocWithDynFlags $ \dflags ->
@@ -330,11 +341,7 @@ instance OutputableBndr Var where
   pprBndr = pprCoreBinder
   pprInfixOcc  = pprInfixName  . varName
   pprPrefixOcc = pprPrefixName . varName
-  pprNonRecBndrKeyword bndr | isJoinId bndr = text "join"
-                            | otherwise     = text "let"
-  pprRecBndrKeyword    bndr | isJoinId bndr = text "joinrec"
-                            | otherwise     = text "letrec"
-  pprLamsOnLhs bndr = isJoinId_maybe bndr `orElse` 0
+  bndrIsJoin_maybe = isJoinId_maybe
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index d78411a893..8a2afbec79 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -962,18 +962,12 @@ class Outputable a => OutputableBndr a where
       -- prefix position of an application, thus   (f a b) or  ((+) x)
       -- or infix position,                 thus   (a `f` b) or  (x + y)
 
-   pprNonRecBndrKeyword, pprRecBndrKeyword :: a -> SDoc
-      -- Print which keyword introduces the binder in Core code. This should be
-      -- "let" or "letrec" for a value but "join" or "joinrec" for a join point.
-   pprNonRecBndrKeyword _ = text "let"
-   pprRecBndrKeyword    _ = text "letrec"
-
-   pprLamsOnLhs :: a -> Int
-      -- 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
-      -- lambda (the first rendering looks like a nullary join point returning
-      -- an n-argument function).
-   pprLamsOnLhs _ = 0
+   bndrIsJoin_maybe :: a -> Maybe Int
+   bndrIsJoin_maybe _ = Nothing
+      -- When pretty-printing we sometimes want to find
+      -- whether the binder is a join point.  You might think
+      -- we could have a function of type (a->Var), but Var
+      -- isn't available yet, alas
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index bc2f85b85f..ee136c24e5 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -44,8 +44,8 @@ T7116.$trModule :: GHC.Types.Module
  Str=m,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-T7116.$trModule =
-  GHC.Types.Module T7116.$trModule3 T7116.$trModule1
+T7116.$trModule
+  = GHC.Types.Module T7116.$trModule3 T7116.$trModule1
 
 -- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0}
 dr :: Double -> Double
@@ -60,9 +60,9 @@ dr :: Double -> Double
                  case x of { GHC.Types.D# x1 ->
                  GHC.Types.D# (GHC.Prim.+## x1 x1)
                  }}]
-dr =
-  \ (x :: Double) ->
-    case x of { GHC.Types.D# x1 -> GHC.Types.D# (GHC.Prim.+## x1 x1) }
+dr
+  = \ (x :: Double) ->
+      case x of { GHC.Types.D# x1 -> GHC.Types.D# (GHC.Prim.+## x1 x1) }
 
 -- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0}
 dl :: Double -> Double
@@ -75,9 +75,9 @@ dl :: Double -> Double
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
          Tmpl= \ (x [Occ=Once!] :: Double) ->
                  case x of { GHC.Types.D# y -> GHC.Types.D# (GHC.Prim.+## y y) }}]
-dl =
-  \ (x :: Double) ->
-    case x of { GHC.Types.D# y -> GHC.Types.D# (GHC.Prim.+## y y) }
+dl
+  = \ (x :: Double) ->
+      case x of { GHC.Types.D# y -> GHC.Types.D# (GHC.Prim.+## y y) }
 
 -- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0}
 fr :: Float -> Float
@@ -92,11 +92,11 @@ fr :: Float -> Float
                  case x of { GHC.Types.F# x1 ->
                  GHC.Types.F# (GHC.Prim.plusFloat# x1 x1)
                  }}]
-fr =
-  \ (x :: Float) ->
-    case x of { GHC.Types.F# x1 ->
-    GHC.Types.F# (GHC.Prim.plusFloat# x1 x1)
-    }
+fr
+  = \ (x :: Float) ->
+      case x of { GHC.Types.F# x1 ->
+      GHC.Types.F# (GHC.Prim.plusFloat# x1 x1)
+      }
 
 -- RHS size: {terms: 8, types: 3, coercions: 0, joins: 0/0}
 fl :: Float -> Float
@@ -111,11 +111,11 @@ fl :: Float -> Float
                  case x of { GHC.Types.F# y ->
                  GHC.Types.F# (GHC.Prim.plusFloat# y y)
                  }}]
-fl =
-  \ (x :: Float) ->
-    case x of { GHC.Types.F# y ->
-    GHC.Types.F# (GHC.Prim.plusFloat# y y)
-    }
+fl
+  = \ (x :: Float) ->
+      case x of { GHC.Types.F# y ->
+      GHC.Types.F# (GHC.Prim.plusFloat# y y)
+      }
 
 
 
diff --git a/testsuite/tests/simplCore/should_compile/T13156.stdout b/testsuite/tests/simplCore/should_compile/T13156.stdout
index 5aa8f6aa38..765c5e188a 100644
--- a/testsuite/tests/simplCore/should_compile/T13156.stdout
+++ b/testsuite/tests/simplCore/should_compile/T13156.stdout
@@ -1,4 +1,4 @@
-    case GHC.List.reverse @ a x of sat { __DEFAULT ->
-    case \ (@ a1) ->
-           case g x of {
-    case r @ GHC.Types.Any of { __DEFAULT -> r @ a }
+      case GHC.List.reverse @ a x of sat { __DEFAULT ->
+      case \ (@ a1) ->
+             case g x of {
+      case r @ GHC.Types.Any of { __DEFAULT -> r @ a }
diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout
index 2afa5e7c0f..f5de5d7835 100644
--- a/testsuite/tests/simplCore/should_compile/T3772.stdout
+++ b/testsuite/tests/simplCore/should_compile/T3772.stdout
@@ -7,23 +7,23 @@ Rec {
 -- RHS size: {terms: 10, types: 2, coercions: 0, joins: 0/0}
 $wxs :: GHC.Prim.Int# -> ()
 [GblId, Arity=1, Caf=NoCafRefs, Str=<S,1*U>]
-$wxs =
-  \ (ww :: GHC.Prim.Int#) ->
-    case ww of ds1 {
-      __DEFAULT -> $wxs (GHC.Prim.-# ds1 1#);
-      1# -> GHC.Tuple.()
-    }
+$wxs
+  = \ (ww :: GHC.Prim.Int#) ->
+      case ww of ds1 {
+        __DEFAULT -> $wxs (GHC.Prim.-# ds1 1#);
+        1# -> GHC.Tuple.()
+      }
 end Rec }
 
 -- RHS size: {terms: 11, types: 3, coercions: 0, joins: 0/0}
 T3772.$wfoo [InlPrag=NOINLINE] :: GHC.Prim.Int# -> ()
 [GblId, Arity=1, Caf=NoCafRefs, Str=<S,U>]
-T3772.$wfoo =
-  \ (ww :: GHC.Prim.Int#) ->
-    case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# 0# ww) of {
-      False -> GHC.Tuple.();
-      True -> $wxs ww
-    }
+T3772.$wfoo
+  = \ (ww :: GHC.Prim.Int#) ->
+      case GHC.Prim.tagToEnum# @ Bool (GHC.Prim.<# 0# ww) of {
+        False -> GHC.Tuple.();
+        True -> $wxs ww
+      }
 
 -- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
 foo [InlPrag=INLINE[0]] :: Int -> ()
@@ -36,8 +36,8 @@ foo [InlPrag=INLINE[0]] :: Int -> ()
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
          Tmpl= \ (w [Occ=Once!] :: Int) ->
                  case w of { GHC.Types.I# ww1 [Occ=Once] -> T3772.$wfoo ww1 }}]
-foo =
-  \ (w :: Int) -> case w of { GHC.Types.I# ww1 -> T3772.$wfoo ww1 }
+foo
+  = \ (w :: Int) -> case w of { GHC.Types.I# ww1 -> T3772.$wfoo ww1 }
 
 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
 T3772.$trModule2 :: GHC.Prim.Addr#
@@ -80,8 +80,8 @@ T3772.$trModule :: GHC.Types.Module
  Str=m,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
-T3772.$trModule =
-  GHC.Types.Module T3772.$trModule3 T3772.$trModule1
+T3772.$trModule
+  = GHC.Types.Module T3772.$trModule3 T3772.$trModule1
 
 
 
diff --git a/testsuite/tests/simplCore/should_compile/T7865.stdout b/testsuite/tests/simplCore/should_compile/T7865.stdout
index 1418e4ebd8..5cf005071d 100644
--- a/testsuite/tests/simplCore/should_compile/T7865.stdout
+++ b/testsuite/tests/simplCore/should_compile/T7865.stdout
@@ -1,8 +1,8 @@
 T7865.$wexpensive [InlPrag=NOINLINE]
-T7865.$wexpensive =
+T7865.$wexpensive
 expensive [InlPrag=INLINE[0]] :: Int -> Int
                  case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
-expensive =
-    case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
-        case T7865.$wexpensive ww1 of ww2 { __DEFAULT ->
-                 case T7865.$wexpensive ww1 of ww2 { __DEFAULT ->
+expensive
+      case T7865.$wexpensive ww1 of ww2 { __DEFAULT -> GHC.Types.I# ww2 }
+            case T7865.$wexpensive ww1 of ww2 { __DEFAULT ->
+                     case T7865.$wexpensive ww1 of ww2 { __DEFAULT ->