Commit 567bc6bd authored by Simon Peyton Jones's avatar Simon Peyton Jones

Improve Lint a little

Better location info if the error is in an unfolding
parent 66d174a9
...@@ -582,7 +582,9 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) ...@@ -582,7 +582,9 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
_ -> return () _ -> return ()
; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder) ; 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 -- We should check the unfolding, if any, but this is tricky because
-- the unfolding is a SimplifiableCoreExpr. Give up for now. -- the unfolding is a SimplifiableCoreExpr. Give up for now.
...@@ -611,7 +613,7 @@ lintRhs bndr rhs ...@@ -611,7 +613,7 @@ lintRhs bndr rhs
; return $ mkLamType var' body_ty } ; return $ mkLamType var' body_ty }
lint_join_lams n tot True _other 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 lint_join_lams _ _ False rhs
= markAllJoinsBad $ lintCoreExpr rhs = markAllJoinsBad $ lintCoreExpr rhs
-- Future join point, not yet eta-expanded -- Future join point, not yet eta-expanded
...@@ -1940,6 +1942,7 @@ instance HasDynFlags LintM where ...@@ -1940,6 +1942,7 @@ instance HasDynFlags LintM where
data LintLocInfo data LintLocInfo
= RhsOf Id -- The variable bound = RhsOf Id -- The variable bound
| LambdaBodyOf Id -- The lambda-binder | LambdaBodyOf Id -- The lambda-binder
| UnfoldingOf Id -- Unfolding of a binder
| BodyOfLetRec [Id] -- One of the binders | BodyOfLetRec [Id] -- One of the binders
| CaseAlt CoreAlt -- Case alternative | CaseAlt CoreAlt -- Case alternative
| CasePat CoreAlt -- The *pattern* of the case alternative | CasePat CoreAlt -- The *pattern* of the case alternative
...@@ -2127,6 +2130,9 @@ dumpLoc (RhsOf v) ...@@ -2127,6 +2130,9 @@ dumpLoc (RhsOf v)
dumpLoc (LambdaBodyOf b) dumpLoc (LambdaBodyOf b)
= (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder 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 []) dumpLoc (BodyOfLetRec [])
= (noSrcLoc, brackets (text "In body of a letrec with no binders")) = (noSrcLoc, brackets (text "In body of a letrec with no binders"))
...@@ -2353,12 +2359,14 @@ mkInvalidJoinPointMsg var ty ...@@ -2353,12 +2359,14 @@ mkInvalidJoinPointMsg var ty
= hang (text "Join point has invalid type:") = hang (text "Join point has invalid type:")
2 (ppr var <+> dcolon <+> ppr ty) 2 (ppr var <+> dcolon <+> ppr ty)
mkBadJoinArityMsg :: Var -> Int -> Int -> SDoc mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc
mkBadJoinArityMsg var ar nlams mkBadJoinArityMsg var ar nlams rhs
= vcat [ text "Join point has too few lambdas", = vcat [ text "Join point has too few lambdas",
text "Join var:" <+> ppr var, text "Join var:" <+> ppr var,
text "Join arity:" <+> ppr ar, 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 -> SDoc
invalidJoinOcc var invalidJoinOcc var
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment