Skip to content

Commit b1152f5

Browse files
amiraliesamiralies
committed
POC: print patterns using rescript printer
1 parent 6feb8a1 commit b1152f5

File tree

8 files changed

+77
-18
lines changed

8 files changed

+77
-18
lines changed

‎jscomp/common/pattern_printer.ml

Lines changed: 43 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
open Types
2+
open Typedtree
3+
4+
let mkpat desc = Ast_helper.Pat.mk desc
5+
6+
let untype typed =
7+
let rec loop pat =
8+
match pat.pat_desc with
9+
| Tpat_or (pa, pb, _) -> mkpat (Ppat_or (loop pa, loop pb))
10+
| Tpat_any | Tpat_var _ -> mkpat Ppat_any
11+
| Tpat_constant c -> mkpat (Ppat_constant (Untypeast.constant c))
12+
| Tpat_alias (p, _, _) -> loop p
13+
| Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst))
14+
| Tpat_construct (cstr_lid, cstr, lst) ->
15+
let lid = { cstr_lid with txt = Longident.Lident cstr.cstr_name } in
16+
let arg =
17+
match List.map loop lst with
18+
| [] -> None
19+
| [ p ] -> Some p
20+
| lst -> Some (mkpat (Ppat_tuple lst))
21+
in
22+
mkpat (Ppat_construct (lid, arg))
23+
| Tpat_variant (label, p_opt, _row_desc) ->
24+
let arg = Option.map loop p_opt in
25+
mkpat (Ppat_variant (label, arg))
26+
| Tpat_record (subpatterns, closed_flag) ->
27+
let fields =
28+
List.map
29+
(fun (_, lbl, p) ->
30+
(mknoloc (Longident.Lident lbl.lbl_name), loop p))
31+
subpatterns
32+
in
33+
mkpat (Ppat_record (fields, closed_flag))
34+
| Tpat_array lst -> mkpat (Ppat_array (List.map loop lst))
35+
| Tpat_lazy p -> mkpat (Ppat_lazy (loop p))
36+
in
37+
let ps = loop typed in
38+
ps
39+
40+
let print_pattern typed =
41+
let pat = untype typed in
42+
let doc = Res_printer.printPattern pat Res_comments_table.empty in
43+
Res_doc.toString ~width:80 doc

‎jscomp/common/pattern_printer.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
val print_pattern : Typedtree.pattern -> string

‎jscomp/core/bs_conditional_initial.ml

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,7 @@ let setup_env () =
3434
Ctype.variant_is_subtype := Matching_polyfill.variant_is_subtype;
3535
Clflags.dump_location := false;
3636
Config.syntax_kind := `rescript;
37+
Parmatch.print_res_pat := Pattern_printer.print_pattern;
3738

3839
# 38 "core/bs_conditional_initial.pp.ml"
3940
Clflags.color := Some Always;
@@ -73,4 +74,4 @@ let setup_env () =
7374

7475

7576
let () =
76-
at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ())
77+
at_exit (fun _ -> Format.pp_print_flush Format.err_formatter ())

‎jscomp/ml/parmatch.ml

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -367,6 +367,9 @@ let get_type_path ty tenv =
367367
(* Values as patterns pretty printer *)
368368
(*************************************)
369369

370+
let print_res_pat: (Typedtree.pattern -> string) ref =
371+
ref (fun _ -> assert false)
372+
370373
open Format
371374
;;
372375

@@ -2090,8 +2093,7 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
20902093
let errmsg =
20912094
try
20922095
let buf = Buffer.create 16 in
2093-
let fmt = formatter_of_buffer buf in
2094-
top_pretty fmt v;
2096+
Buffer.add_string buf (!print_res_pat v);
20952097
begin match check_partial_all v casel with
20962098
| None -> ()
20972099
| Some _ ->

‎jscomp/ml/parmatch.mli

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -24,6 +24,8 @@ val pretty_pat : pattern -> unit
2424
val pretty_line : pattern list -> unit
2525
val pretty_matrix : pattern list list -> unit
2626

27+
val print_res_pat: (Typedtree.pattern -> string) ref
28+
2729
val omega : pattern
2830
val omegas : int -> pattern list
2931
val omega_list : 'a list -> pattern list

‎lib/4.06.1/unstable/js_compiler.ml

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -17624,10 +17624,8 @@ end = struct
1762417624
* You should have received a copy of the GNU Lesser General Public License
1762517625
* along with this program; if not, write to the Free Software
1762617626
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
17627-
let version = "10.0.0"
17628-
17627+
let version = "10.0.0-beta.1"
1762917628
let header = "// Generated by ReScript, PLEASE EDIT WITH CARE"
17630-
1763117629
let package_name = ref "rescript"
1763217630

1763317631
end
@@ -26327,6 +26325,8 @@ val pretty_pat : pattern -> unit
2632726325
val pretty_line : pattern list -> unit
2632826326
val pretty_matrix : pattern list list -> unit
2632926327

26328+
val print_res_pat: (Typedtree.pattern -> string) ref
26329+
2633026330
val omega : pattern
2633126331
val omegas : int -> pattern list
2633226332
val omega_list : 'a list -> pattern list
@@ -26773,6 +26773,9 @@ let get_type_path ty tenv =
2677326773
(* Values as patterns pretty printer *)
2677426774
(*************************************)
2677526775

26776+
let print_res_pat: (Typedtree.pattern -> string) ref =
26777+
ref (fun _ -> assert false)
26778+
2677626779
open Format
2677726780
;;
2677826781

@@ -28496,8 +28499,7 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
2849628499
let errmsg =
2849728500
try
2849828501
let buf = Buffer.create 16 in
28499-
let fmt = formatter_of_buffer buf in
28500-
top_pretty fmt v;
28502+
Buffer.add_string buf (!print_res_pat v);
2850128503
begin match check_partial_all v casel with
2850228504
| None -> ()
2850328505
| Some _ ->

‎lib/4.06.1/unstable/js_playground_compiler.ml

Lines changed: 9 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -17624,10 +17624,8 @@ end = struct
1762417624
* You should have received a copy of the GNU Lesser General Public License
1762517625
* along with this program; if not, write to the Free Software
1762617626
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
17627-
let version = "10.0.0"
17628-
17627+
let version = "10.0.0-beta.1"
1762917628
let header = "// Generated by ReScript, PLEASE EDIT WITH CARE"
17630-
1763117629
let package_name = ref "rescript"
1763217630

1763317631
end
@@ -26327,6 +26325,8 @@ val pretty_pat : pattern -> unit
2632726325
val pretty_line : pattern list -> unit
2632826326
val pretty_matrix : pattern list list -> unit
2632926327

26328+
val print_res_pat: (Typedtree.pattern -> string) ref
26329+
2633026330
val omega : pattern
2633126331
val omegas : int -> pattern list
2633226332
val omega_list : 'a list -> pattern list
@@ -26773,6 +26773,9 @@ let get_type_path ty tenv =
2677326773
(* Values as patterns pretty printer *)
2677426774
(*************************************)
2677526775

26776+
let print_res_pat: (Typedtree.pattern -> string) ref =
26777+
ref (fun _ -> assert false)
26778+
2677626779
open Format
2677726780
;;
2677826781

@@ -28496,8 +28499,7 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
2849628499
let errmsg =
2849728500
try
2849828501
let buf = Buffer.create 16 in
28499-
let fmt = formatter_of_buffer buf in
28500-
top_pretty fmt v;
28502+
Buffer.add_string buf (!print_res_pat v);
2850128503
begin match check_partial_all v casel with
2850228504
| None -> ()
2850328505
| Some _ ->
@@ -275584,6 +275586,8 @@ val addParens : Res_doc.t -> Res_doc.t
275584275586

275585275587
val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t
275586275588

275589+
val printPattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t
275590+
275587275591
val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t
275588275592
[@@live]
275589275593

‎lib/4.06.1/whole_compiler.ml

Lines changed: 9 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -179895,10 +179895,8 @@ end = struct
179895179895
* You should have received a copy of the GNU Lesser General Public License
179896179896
* along with this program; if not, write to the Free Software
179897179897
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
179898-
let version = "10.0.0"
179899-
179898+
let version = "10.0.0-beta.1"
179900179899
let header = "// Generated by ReScript, PLEASE EDIT WITH CARE"
179901-
179902179900
let package_name = ref "rescript"
179903179901

179904179902
end
@@ -186268,6 +186266,8 @@ val pretty_pat : pattern -> unit
186268186266
val pretty_line : pattern list -> unit
186269186267
val pretty_matrix : pattern list list -> unit
186270186268

186269+
val print_res_pat: (Typedtree.pattern -> string) ref
186270+
186271186271
val omega : pattern
186272186272
val omegas : int -> pattern list
186273186273
val omega_list : 'a list -> pattern list
@@ -186714,6 +186714,9 @@ let get_type_path ty tenv =
186714186714
(* Values as patterns pretty printer *)
186715186715
(*************************************)
186716186716

186717+
let print_res_pat: (Typedtree.pattern -> string) ref =
186718+
ref (fun _ -> assert false)
186719+
186717186720
open Format
186718186721
;;
186719186722

@@ -188437,8 +188440,7 @@ let do_check_partial ?pred exhaust loc casel pss = match pss with
188437188440
let errmsg =
188438188441
try
188439188442
let buf = Buffer.create 16 in
188440-
let fmt = formatter_of_buffer buf in
188441-
top_pretty fmt v;
188443+
Buffer.add_string buf (!print_res_pat v);
188442188444
begin match check_partial_all v casel with
188443188445
| None -> ()
188444188446
| Some _ ->
@@ -281326,6 +281328,8 @@ val addParens : Res_doc.t -> Res_doc.t
281326281328

281327281329
val printExpression : Parsetree.expression -> Res_comments_table.t -> Res_doc.t
281328281330

281331+
val printPattern : Parsetree.pattern -> Res_comments_table.t -> Res_doc.t
281332+
281329281333
val printStructure : Parsetree.structure -> Res_comments_table.t -> Res_doc.t
281330281334
[@@live]
281331281335

0 commit comments

Comments
 (0)