[commit: ghc] master: Don't crash when pretty-printing bad joins (07cc603)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/07cc6039dccff82790bf1d84a81e26df234ad899/ghc

>---------------------------------------------------------------

commit 07cc6039dccff82790bf1d84a81e26df234ad899
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue May 1 11:11:46 2018 +0100

    Don't crash when pretty-printing bad joins
    
    Trac #15108 showed that the Core pretty-printer would
    crash if it found a join-point binding with too few lambda
    on the RHS.  That is super-unhelpful!  Lint will find it,
    but pretty-printing should not crash.
    
    This patch just makes the pretty printer behave more robustly;
    it leaves the job of error reporting to Lint.


>---------------------------------------------------------------

07cc6039dccff82790bf1d84a81e26df234ad899
 compiler/coreSyn/PprCore.hs | 10 +++++++++-
 1 file changed, 9 insertions(+), 1 deletion(-)

diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index 96f7aa5..ca2b8af 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -128,10 +128,18 @@ ppr_binding ann (val_bdr, expr)
       -- lambda (the first rendering looks like a nullary join point returning
       -- an n-argument function).
     pp_join_bind join_arity
+      | bndrs `lengthAtLeast` join_arity
       = hang (ppr 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
+                  -- the pretty-printer else we can't see what's wrong
+                  -- So refer to printing  j = e
+      = pp_normal_bind
       where
-        (lhs_bndrs, rhs) = collectNBinders join_arity expr
+        (bndrs, body) = collectBinders expr
+        lhs_bndrs = take join_arity bndrs
+        rhs       = mkLams (drop join_arity bndrs) body
 
 pprParendExpr expr = ppr_expr parens expr
 pprCoreExpr   expr = ppr_expr noParens expr