- warn sty | length pats > maximum_output =
- hang (pp_context sty ctx (ptext SLIT("are non-exhaustive")))
- 12 (hang (ptext SLIT("Patterns not recognized:"))
- 4 ((vcat $ map (ppr_incomplete_pats kind sty) (take maximum_output pats))
- $$ ptext SLIT("...")))
- warn sty =
- hang (pp_context sty ctx (ptext SLIT("are non-exhaustive")))
- 12 (hang (ptext SLIT("Patterns not recognized:"))
- 4 (vcat $ map (ppr_incomplete_pats kind sty) pats))
-
-pp_context sty NoMatchContext msg = ptext SLIT("Warning: Some match(es)") <+> msg
-
-pp_context sty (DsMatchContext kind pats loc) msg
- = hang (hcat [ppr (PprForUser opt_PprUserLength) loc, ptext SLIT(": ")])
- 4 (hang message
- 4 (pp_match kind pats))
- where
- message = ptext SLIT("Warning: Pattern match(es)") <+> msg
-
- pp_match (FunMatch fun) pats
- = hsep [ptext SLIT("in the definition of function"), ppr sty fun]
-
- pp_match CaseMatch pats
- = hang (ptext SLIT("in a group of case alternatives beginning:"))
- 4 (ppr_pats sty pats)
-
- pp_match PatBindMatch pats
- = hang (ptext SLIT("in a pattern binding:"))
- 4 (ppr_pats sty pats)
-
- pp_match LambdaMatch pats
- = hang (ptext SLIT("in a lambda abstraction:"))
- 4 (ppr_pats sty pats)
-
- pp_match DoBindMatch pats
- = hang (ptext SLIT("in a `do' pattern binding:"))
- 4 (ppr_pats sty pats)
-
- pp_match ListCompMatch pats
- = hang (ptext SLIT("in a `list comprension' pattern binding:"))
- 4 (ppr_pats sty pats)
-
- pp_match LetMatch pats
- = hang (ptext SLIT("in a `let' pattern binding:"))
- 4 (ppr_pats sty pats)
-
-ppr_pats sty pats = pprQuote sty $ \ sty -> sep (map (ppr sty) 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 sty pats = pprQuote sty $ \ sty ->
- sep [sep (map (ppr sty) pats), ptext (separator kind), ptext SLIT("...")]
+ warn = pp_context ctx (ptext SLIT("are non-exhaustive"))
+ (\f -> hang (ptext SLIT("Patterns not matched:"))
+ 4 ((vcat $ map (ppr_incomplete_pats kind)
+ (take maximum_output pats))
+ $$ dots))
+
+ dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
+ | otherwise = empty
+
+pp_context NoMatchContext msg rest_of_msg_fun
+ = (noSrcLoc, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
+
+pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
+ = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg,
+ sep [ptext SLIT("In") <+> ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]])
+ where
+ (ppr_match, pref)
+ = case kind of
+ FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)
+ other -> (pprMatchContext kind, \ pp -> pp)
+
+ppr_pats pats = sep (map ppr pats)
+
+ppr_shadow_pats kind pats
+ = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]