[commit: ghc] ghc-8.2: Improve Lint a little (81abf7b)

[git at git.haskell.org]

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

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/81abf7b4da850b1003af0740c3ca9aab893d654b/ghc

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

commit 81abf7b4da850b1003af0740c3ca9aab893d654b
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Mar 17 08:54:39 2017 +0000

    Improve Lint a little
    
    Better location info if the error is in an unfolding
    
    (cherry picked from commit 567bc6bd194836233ce1576acd7a62b1867f6607)


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

81abf7b4da850b1003af0740c3ca9aab893d654b
 compiler/coreSyn/CoreLint.hs | 18 +++++++++++++-----
 1 file changed, 13 insertions(+), 5 deletions(-)

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 93fcbe4..714006c 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -580,7 +580,9 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
            _ -> return ()
 
        ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)
-       ; lintIdUnfolding binder binder_ty (idUnfolding binder) }
+
+       ; addLoc (UnfoldingOf binder) $
+         lintIdUnfolding binder binder_ty (idUnfolding binder) }
 
         -- We should check the unfolding, if any, but this is tricky because
         -- the unfolding is a SimplifiableCoreExpr. Give up for now.
@@ -609,7 +611,7 @@ lintRhs bndr rhs
            ; return $ mkLamType var' body_ty }
 
     lint_join_lams n tot True _other
-      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n)
+      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs
     lint_join_lams _ _ False rhs
       = markAllJoinsBad $ lintCoreExpr rhs
           -- Future join point, not yet eta-expanded
@@ -1938,6 +1940,7 @@ instance HasDynFlags LintM where
 data LintLocInfo
   = RhsOf Id            -- The variable bound
   | LambdaBodyOf Id     -- The lambda-binder
+  | UnfoldingOf Id      -- Unfolding of a binder
   | BodyOfLetRec [Id]   -- One of the binders
   | CaseAlt CoreAlt     -- Case alternative
   | CasePat CoreAlt     -- The *pattern* of the case alternative
@@ -2125,6 +2128,9 @@ dumpLoc (RhsOf v)
 dumpLoc (LambdaBodyOf b)
   = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))
 
+dumpLoc (UnfoldingOf b)
+  = (getSrcLoc b, brackets (text "in the unfolding of" <+> pp_binder b))
+
 dumpLoc (BodyOfLetRec [])
   = (noSrcLoc, brackets (text "In body of a letrec with no binders"))
 
@@ -2351,12 +2357,14 @@ mkInvalidJoinPointMsg var ty
   = hang (text "Join point has invalid type:")
         2 (ppr var <+> dcolon <+> ppr ty)
 
-mkBadJoinArityMsg :: Var -> Int -> Int -> SDoc
-mkBadJoinArityMsg var ar nlams
+mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
+mkBadJoinArityMsg var ar nlams rhs
   = vcat [ text "Join point has too few lambdas",
            text "Join var:" <+> ppr var,
            text "Join arity:" <+> ppr ar,
-           text "Number of lambdas:" <+> ppr nlams ]
+           text "Number of lambdas:" <+> ppr nlams,
+           text "Rhs = " <+> ppr rhs
+           ]
 
 invalidJoinOcc :: Var -> SDoc
 invalidJoinOcc var