-mkConErrMsg e
- = ($$) (ptext SLIT("Application of newtype constructor:"))
- (ppr e)
-
-mkCoerceErrMsg e
- = ($$) (ptext SLIT("Coercion using a datatype constructor:"))
- (ppr e)
-
-
-mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
-mkCaseAltMsg alts
- = ($$) (ptext SLIT("Type of case alternatives not the same:"))
- (ppr alts)
-
-mkCaseDataConMsg :: CoreExpr -> ErrMsg
-mkCaseDataConMsg expr
- = ($$) (ptext SLIT("A case scrutinee not of data constructor type:"))
- (pprCoreExpr expr)
-
-mkCaseNotPrimMsg :: TyCon -> ErrMsg
-mkCaseNotPrimMsg tycon
- = ($$) (ptext SLIT("A primitive case on a non-primitive type:"))
- (ppr tycon)
-
-mkCasePrimMsg :: TyCon -> ErrMsg
-mkCasePrimMsg tycon
- = ($$) (ptext SLIT("An algebraic case on a primitive type:"))
- (ppr tycon)
-
-mkCaseAbstractMsg :: TyCon -> ErrMsg
-mkCaseAbstractMsg tycon
- = ($$) (ptext SLIT("An algebraic case on some weird type:"))
- (ppr tycon)
-
-mkDefltMsg :: CoreCaseDefault -> ErrMsg
-mkDefltMsg deflt
- = ($$) (ptext SLIT("Binder in case default doesn't match type of scrutinee:"))
- (ppr deflt)
-
-mkAppMsg :: Type -> Type -> CoreExpr -> ErrMsg
-mkAppMsg fun arg expr
+pprLoc (RhsOf v)
+ = ppr (getSrcLoc v) <> colon <+>
+ brackets (ptext SLIT("RHS of") <+> pp_binders [v])
+
+pprLoc (LambdaBodyOf b)
+ = ppr (getSrcLoc b) <> colon <+>
+ brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
+
+pprLoc (BodyOfLetRec bs)
+ = ppr (getSrcLoc (head bs)) <> colon <+>
+ brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
+
+pprLoc (AnExpr e)
+ = text "In the expression:" <+> ppr e
+
+pprLoc (CaseAlt (con, args, rhs))
+ = text "In a case pattern:" <+> parens (ppr con <+> ppr args)
+
+pprLoc (ImportedUnfolding locn)
+ = ppr locn <> colon <+>
+ brackets (ptext SLIT("in an imported unfolding"))
+
+pp_binders :: [Id] -> SDoc
+pp_binders bs = sep (punctuate comma (map pp_binder bs))
+
+pp_binder :: Id -> SDoc
+pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
+\end{code}
+
+\begin{code}
+------------------------------------------------------
+-- Messages for case expressions
+
+mkConAppMsg :: CoreExpr -> ErrMsg
+mkConAppMsg e
+ = hang (text "Application of newtype constructor:")
+ 4 (ppr e)
+
+mkConAltMsg :: Con -> ErrMsg
+mkConAltMsg con
+ = text "PrimOp in case pattern:" <+> ppr con
+
+mkNullAltsMsg :: CoreExpr -> ErrMsg
+mkNullAltsMsg e
+ = hang (text "Case expression with no alternatives:")
+ 4 (ppr e)
+
+mkDefaultArgsMsg :: [IdOrTyVar] -> ErrMsg
+mkDefaultArgsMsg args
+ = hang (text "DEFAULT case with binders")
+ 4 (ppr args)
+
+mkCaseAltMsg :: CoreExpr -> ErrMsg
+mkCaseAltMsg e
+ = hang (text "Type of case alternatives not the same:")
+ 4 (ppr e)
+
+mkScrutMsg :: Id -> Type -> ErrMsg
+mkScrutMsg var scrut_ty
+ = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
+ text "Result binder type:" <+> ppr (idType var),
+ text "Scrutinee type:" <+> ppr scrut_ty]
+
+badAltsMsg :: CoreExpr -> ErrMsg
+badAltsMsg e
+ = hang (text "Case statement scrutinee is not a data type:")
+ 4 (ppr e)
+
+nonExhaustiveAltsMsg :: CoreExpr -> ErrMsg
+nonExhaustiveAltsMsg e
+ = hang (text "Case expression with non-exhaustive alternatives")
+ 4 (ppr e)
+
+mkBadPatMsg :: Type -> Type -> ErrMsg
+mkBadPatMsg con_result_ty scrut_ty
+ = vcat [
+ text "In a case alternative, pattern result type doesn't match scrutinee type:",
+ text "Pattern result type:" <+> ppr con_result_ty,
+ text "Scrutinee type:" <+> ppr scrut_ty
+ ]
+
+------------------------------------------------------
+-- Other error messages
+
+mkAppMsg :: Type -> Type -> ErrMsg
+mkAppMsg fun arg