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.

4 files changed, 33 insertions, 35 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
 
 {-
 ************************************************************************