POC: print patterns in warnings using rescript printer

jscomp/build_tests/super_errors/expected/warnings4.res.expected

@@ -10,4 +10,4 @@
   14 │ 
 
   You forgot to handle a possible case here, for example: 
-  #second(_) | #fourth | #third
+  #second(_) | #fourth | #third

jscomp/build_tests/super_errors/expected/warnings5.res.expected

@@ -24,7 +24,7 @@ Either bind these labels explicitly or add ', _' to the pattern.
   15 │ switch y {
 
   You forgot to handle a possible case here, for example: 
-  {otherValue: true}
+  {otherValue: true, _}
 
 
   Warning number 9
@@ -52,8 +52,8 @@ Either bind these labels explicitly or add ', _' to the pattern.
   19 │ let arr = [1]
 
   You forgot to handle a possible case here, for example: 
-  {typ: WithPayload(false)} | 
-{typ: Variant | One | Two | Three | Four | Five | Six | Seven(_)}
+  {typ: WithPayload(false), _}
+| {typ: Variant | One | Two | Three | Four | Five | Six | Seven(_), _}
 
 
   Warning number 8
@@ -95,6 +95,96 @@ Either bind these labels explicitly or add ', _' to the pattern.
   30 │ | [1, 2] => ()
   31 │ }
   32 │ 
+  33 │ let lst = list{}
 
   You forgot to handle a possible case here, for example: 
-  [1, 0] | [0, _] | []
+  [1, 0] | [0, _] | []
+
+
+  Warning number 8
+  /.../fixtures/warnings5.res:35:1-37:1
+
+  33 │ let lst = list{}
+  34 │ 
+  35 │ switch lst {
+  36 │ | list{} => ()
+  37 │ }
+  38 │ 
+  39 │ switch lst {
+
+  You forgot to handle a possible case here, for example: 
+  list{_, ..._}
+
+
+  Warning number 8
+  /.../fixtures/warnings5.res:39:1-41:1
+
+  37 │ }
+  38 │ 
+  39 │ switch lst {
+  40 │ | list{1, 2} => ()
+  41 │ }
+  42 │ 
+  43 │ switch lst {
+
+  You forgot to handle a possible case here, for example: 
+  list{1, 2, _, ..._} | list{1, 0, ..._} | list{1} | list{0, ..._} | list{}
+
+
+  Warning number 8
+  /.../fixtures/warnings5.res:43:1-45:1
+
+  41 │ }
+  42 │ 
+  43 │ switch lst {
+  44 │ | list{1} => ()
+  45 │ }
+  46 │ 
+  47 │ switch "abc" {
+
+  You forgot to handle a possible case here, for example: 
+  list{1, _, ..._} | list{0, ..._} | list{}
+
+
+  Warning number 8
+  /.../fixtures/warnings5.res:47:1-49:1
+
+  45 │ }
+  46 │ 
+  47 │ switch "abc" {
+  48 │ | "" => ()
+  49 │ }
+  50 │ 
+  51 │ switch 0 {
+
+  You forgot to handle a possible case here, for example: 
+  "*"
+
+
+  Warning number 8
+  /.../fixtures/warnings5.res:51:1-53:1
+
+  49 │ }
+  50 │ 
+  51 │ switch 0 {
+  52 │ | 1 => ()
+  53 │ }
+  54 │ 
+  55 │ let tuple = (1, true)
+
+  You forgot to handle a possible case here, for example: 
+  0
+
+
+  Warning number 8
+  /.../fixtures/warnings5.res:57:1-59:1
+
+  55 │ let tuple = (1, true)
+  56 │ 
+  57 │ switch tuple {
+  58 │ | (_, false) => ()
+  59 │ }
+  60 │ 
+
+  You forgot to handle a possible case here, for example: 
+  (_, true)

jscomp/build_tests/super_errors/fixtures/warnings5.res

@@ -29,3 +29,31 @@ switch arr {
 switch arr {
 | [1, 2] => ()
 }
+
+let lst = list{}
+
+switch lst {
+| list{} => ()
+}
+
+switch lst {
+| list{1, 2} => ()
+}
+
+switch lst {
+| list{1} => ()
+}
+
+switch "abc" {
+| "" => ()
+}
+
+switch 0 {
+| 1 => ()
+}
+
+let tuple = (1, true)
+
+switch tuple {
+| (_, false) => ()
+}

jscomp/common/pattern_printer.ml

@@ -0,0 +1,48 @@
+open Types
+open Typedtree
+open Parsetree
+
+let mkpat desc = Ast_helper.Pat.mk desc
+
+let untype typed =
+  let rec loop pat =
+    match pat.pat_desc with
+    | Tpat_or (p1, { pat_desc = Tpat_or (p2, p3, rI) }, rO) ->
+      (* Turn A | (B | C) into (A | B) | C for pretty printing without parens *)
+        let newInner = { pat with pat_desc = Tpat_or (p1, p2, rI) } in
+        let newOuter = { pat with pat_desc = Tpat_or (newInner, p3, rO) } in
+        loop newOuter
+    | Tpat_or (pa, pb, _) -> mkpat (Ppat_or (loop pa, loop pb))
+    | Tpat_any | Tpat_var _ -> mkpat Ppat_any
+    | Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c))
+    | Tpat_alias (p, _, _) -> loop p
+    | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst))
+    | Tpat_construct (cstr_lid, cstr, lst) ->
+        let lid = { cstr_lid with txt = Longident.Lident cstr.cstr_name } in
+        let arg =
+          match List.map loop lst with
+          | [] -> None
+          | [ p ] -> Some p
+          | lst -> Some (mkpat (Ppat_tuple lst))
+        in
+        mkpat (Ppat_construct (lid, arg))
+    | Tpat_variant (label, p_opt, _row_desc) ->
+        let arg = Option.map loop p_opt in
+        mkpat (Ppat_variant (label, arg))
+    | Tpat_record (subpatterns, closed_flag) ->
+        let fields =
+          List.map
+            (fun (_, lbl, p) ->
+              (mknoloc (Longident.Lident lbl.lbl_name), loop p))
+            subpatterns
+        in
+        mkpat (Ppat_record (fields, closed_flag))
+    | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst))
+    | Tpat_lazy p -> mkpat (Ppat_lazy (loop p))
+  in
+  loop typed
+
+let print_pattern typed =
+  let pat = untype typed in
+  let doc = Res_printer.printPattern pat Res_comments_table.empty in
+  Res_doc.toString ~width:80 doc

jscomp/common/pattern_printer.mli

@@ -0,0 +1,2 @@
+(* Should be used just for error messages. slightly tweaks rescript printer's logic*)
+val print_pattern : Typedtree.pattern -> string

jscomp/core/bs_conditional_initial.ml

@@ -34,11 +34,12 @@ let setup_env () =
   Ctype.variant_is_subtype := Matching_polyfill.variant_is_subtype;
   Clflags.dump_location := false;  
   Config.syntax_kind := `rescript;
+  Parmatch.print_res_pat := Pattern_printer.print_pattern;
 
-# 38 "core/bs_conditional_initial.pp.ml"
+# 39 "core/bs_conditional_initial.pp.ml"
   Clflags.color := Some Always;
 
-# 40 "core/bs_conditional_initial.pp.ml"
+# 41 "core/bs_conditional_initial.pp.ml"
   (* default true
      otherwise [bsc -I sc src/hello.ml ] will include current directory to search path
   *)
@@ -55,7 +56,7 @@ let setup_env () =
   Matching.names_from_construct_pattern := 
     Matching_polyfill.names_from_construct_pattern;
 
-# 56 "core/bs_conditional_initial.pp.ml"
+# 57 "core/bs_conditional_initial.pp.ml"
     (let root_dir = 
        Filename.dirname 
          (Filename.dirname Sys.executable_name) in 
@@ -65,12 +66,12 @@ let setup_env () =
        (root_dir//"jscomp"//"stdlib-406") ::
        !Clflags.include_dirs);
 
-# 65 "core/bs_conditional_initial.pp.ml"
+# 66 "core/bs_conditional_initial.pp.ml"
   Rescript_cpp.replace_directive_bool "BS" true;
   Rescript_cpp.replace_directive_bool "JS" true;
   Rescript_cpp.replace_directive_string "BS_VERSION"  Bs_version.version
   (*; Switch.cut := 100*) (* tweakable but not very useful *)
 
 
 let () = 
-  at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ())
+  at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ())

jscomp/core/bs_conditional_initial.pp.ml

@@ -33,6 +33,7 @@ let setup_env () =
   Ctype.variant_is_subtype := Matching_polyfill.variant_is_subtype;
   Clflags.dump_location := false;  
   Config.syntax_kind := `rescript;
+  Parmatch.print_res_pat := Pattern_printer.print_pattern;
 #ifdef BROWSER
 #else    
   Clflags.color := Some Always;
@@ -69,4 +70,4 @@ let setup_env () =
 
 
 let () = 
-  at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ())
+  at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ())

jscomp/ml/parmatch.ml

@@ -367,6 +367,9 @@ let get_type_path ty tenv =
 (* Values as patterns pretty printer *)
 (*************************************)
 
+let print_res_pat: (Typedtree.pattern -> string) ref =
+  ref (fun _ -> assert false)
+
 open Format
 ;;
 
@@ -2090,8 +2093,7 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
               let errmsg =
                 try
                   let buf = Buffer.create 16 in
-                  let fmt = formatter_of_buffer buf in
-                  top_pretty fmt v;
+                  Buffer.add_string buf (!print_res_pat v);
                   begin match check_partial_all v casel with
                   | None -> ()
                   | Some _ ->

jscomp/ml/parmatch.mli

@@ -24,6 +24,8 @@ val pretty_pat : pattern -> unit
 val pretty_line : pattern list -> unit
 val pretty_matrix : pattern list list -> unit
 
+val print_res_pat: (Typedtree.pattern -> string) ref
+
 val omega : pattern
 val omegas : int -> pattern list
 val omega_list : 'a list -> pattern list