POC: print patterns using rescript printer

Author: amiralies

jscomp/common/pattern_printer.ml

@@ -0,0 +1,43 @@
+open Types
+open Typedtree
+
+let mkpat desc = Ast_helper.Pat.mk desc
+
+let untype typed =
+  let rec loop pat =
+    match pat.pat_desc with
+    | 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
+  let ps = loop typed in
+  ps
+
+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 @@
+val print_pattern : Typedtree.pattern -> string

jscomp/core/bs_conditional_initial.ml

@@ -34,6 +34,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;
 
 # 38 "core/bs_conditional_initial.pp.ml"
   Clflags.color := Some Always;
@@ -73,4 +74,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