+The next two functions creates the warning message.
+
+\begin{code}
+dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
+dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
+ where
+ warn | length qs > maximum_output
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ 8 (vcat (map (ppr_eqn kind) (take maximum_output qs)) $$
+ ptext SLIT("..."))
+ | otherwise
+ = pp_context ctx (ptext SLIT("are overlapped"))
+ 8 (vcat $ map (ppr_eqn kind) qs)
+
+
+dsIncompleteWarn :: DsMatchContext -> [ExhaustivePat] -> DsM ()
+dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
+ where
+ warn | length pats > maximum_output
+ = pp_context ctx (ptext SLIT("are non-exhaustive"))
+ 8 (hang (ptext SLIT("Patterns not recognized:"))
+ 4 ((vcat $ map (ppr_incomplete_pats kind) (take maximum_output pats))
+ $$ ptext SLIT("...")))
+ | otherwise
+ = pp_context ctx (ptext SLIT("are non-exhaustive"))
+ 8 (hang (ptext SLIT("Patterns not recognized:"))
+ 4 (vcat $ map (ppr_incomplete_pats kind) pats))
+
+pp_context NoMatchContext msg ind rest_of_msg = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg ind rest_of_msg)
+
+pp_context (DsMatchContext kind pats loc) msg ind rest_of_msg
+ = addErrLocHdrLine loc message (hang (pp_match kind pats) ind rest_of_msg)
+ where
+ message = ptext SLIT("Pattern match(es)") <+> msg
+
+ pp_match (FunMatch fun) pats
+ = hsep [ptext SLIT("in the definition of function"), quotes (ppr fun)]
+
+ pp_match CaseMatch pats
+ = hang (ptext SLIT("in a group of case alternatives beginning:"))
+ 4 (ppr_pats pats)
+
+ pp_match PatBindMatch pats
+ = hang (ptext SLIT("in a pattern binding:"))
+ 4 (ppr_pats pats)
+
+ pp_match LambdaMatch pats
+ = hang (ptext SLIT("in a lambda abstraction:"))
+ 4 (ppr_pats pats)
+
+ pp_match DoBindMatch pats
+ = hang (ptext SLIT("in a `do' pattern binding:"))
+ 4 (ppr_pats pats)
+
+ pp_match ListCompMatch pats
+ = hang (ptext SLIT("in a `list comprension' pattern binding:"))
+ 4 (ppr_pats pats)
+
+ pp_match LetMatch pats
+ = hang (ptext SLIT("in a `let' pattern binding:"))
+ 4 (ppr_pats pats)
+
+ppr_pats pats = sep (map ppr pats)
+
+separator (FunMatch _) = SLIT("=")
+separator (CaseMatch) = SLIT("->")
+separator (LambdaMatch) = SLIT("->")
+separator (PatBindMatch) = panic "When is this used?"
+separator (DoBindMatch) = SLIT("<-")
+separator (ListCompMatch) = SLIT("<-")
+separator (LetMatch) = SLIT("=")
+
+ppr_shadow_pats kind pats = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")]
+
+ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
+ppr_incomplete_pats kind (pats,constraints) =
+ sep [ppr_pats pats, ptext SLIT("with"),
+ sep (map ppr_constraint constraints)]
+
+
+ppr_constraint (var,pats) = sep [ppr var, ptext SLIT("`not_elem`"), ppr pats]
+
+ppr_eqn kind (EqnInfo _ _ pats _) = ppr_shadow_pats kind pats
+\end{code}
+
+