Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Matching: more debug #12553

Merged
merged 4 commits into from Sep 13, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
2 changes: 1 addition & 1 deletion Changes
Expand Up @@ -281,7 +281,7 @@ Working version
artifacts in preparation for better unicode support for OCaml source files.
(Florian Angeletti, review by Gabriel Scherer)

- #12532: improve readability of the pattern-matching debug output
- #12532, #12553: improve readability of the pattern-matching debug output
(Gabriel Scherer, review by Thomas Refis)

### Build system:
Expand Down
18 changes: 12 additions & 6 deletions lambda/matching.ml
Expand Up @@ -104,6 +104,10 @@ let debugf fmt =
then Format.eprintf fmt
else Format.ifprintf Format.err_formatter fmt

let pp_partial ppf = function
| Total -> Format.fprintf ppf "Total"
| Partial -> Format.fprintf ppf "Partial"

(*
Compatibility predicate that considers potential rebindings of constructors
of an extension type.
Expand Down Expand Up @@ -2731,6 +2735,10 @@ let complete_pats_constrs = function
*)

let mk_failaction_neg partial ctx def =
debugf
"@,@[<v 2>COMBINE (mk_failaction_neg %a)@]"
pp_partial partial
;
match partial with
| Partial -> (
match Default_environment.pop def with
Expand Down Expand Up @@ -2779,13 +2787,14 @@ let mk_failaction_pos partial seen ctx defs =
defs
in
debugf
"@,@[<v 2>COMBINE (mk_failaction_pos)@,\
"@,@[<v 2>COMBINE (mk_failaction_pos %a)@,\
%a@,\
@[<v 2>FAIL PATTERNS:@,\
%a@]@,\
@[<v 2>POSITIVE JUMPS:@,\
%a@]\
@]"
pp_partial partial
Default_environment.pp defs
(Format.pp_print_list ~pp_sep:Format.pp_print_cut
Printpat.pretty_pat) fail_pats
Expand Down Expand Up @@ -3427,12 +3436,9 @@ and combine_handlers ~scopes repr partial ctx (v, str, arg) first_match rem =
(* verbose version of do_compile_matching, for debug *)
and do_compile_matching_pr ~scopes repr partial ctx x =
debugf
"@[<v>MATCH %s\
"@[<v>MATCH %a\
@,%a"
( match partial with
| Partial -> "Partial"
| Total -> "Total"
)
pp_partial partial
pretty_precompiled x;
debugf "@,@[<v 2>CTX:@,%a@]"
Context.pp ctx;
Expand Down
2 changes: 1 addition & 1 deletion testsuite/tests/typing-warnings/exhaustiveness.ml
Expand Up @@ -333,7 +333,7 @@ Line 1, characters 8-37:
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Warning 8 [partial-match]: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
(_, 1)
({ _ }, 1)

val f : 'a ref * int -> int = <fun>
|}]
Expand Down
2 changes: 1 addition & 1 deletion typing/printpat.ml
Expand Up @@ -84,7 +84,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
| (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
| _ -> true) lvs in
begin match filtered_lvs with
| [] -> fprintf ppf "_"
| [] -> fprintf ppf "{ _ }"
| (_, lbl, _) :: q ->
let elision_mark ppf =
(* we assume that there is no label repetitions here *)
Expand Down